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anagram.pas 

Programming Project: "Anagram Solving In Pascal," by 
Bob Keefer. July, page 113. Also see setprob.pas. 


program Anagram; 

{Copyright 1985 by Bob Keefer} 

{Anagram.Pas takes a word of up to 10 letters from 
the keyboard and rearranges the letters into every 
possible permutation, or anagram, of the word.} 

{It then evaluates the likelihood that each anagram 
is an English word by looking up every trigram in 
the word in a probability table, which is stored in 
a separate file PROB.DAT and is read into the array 
ProbabiI Ity[X,Y,Z]. Finally, it records the top 
scoring anagrams in Scoreboard and prints them to 
the screen.} 

{The program must be compiled with the Turbo 
"c" compiler option to a *.COM file.} 


j$A-| jcompiler directive for recursion} 
|$C-| .... ignore and ~S breaks} 
{$I-| j.... no i/o checking} 

|$V“} {.... no string checking} 


const 

MaxLength - 13; jbiggest word + 3} 

MaxScores « 15 ; {how many winners to store} 

type 

ScoreLIne * record {One line of the Scoreboard} 
Winner : string[MaxLength] ; 

Points ; integer ; 
end; 


var 

Word : array [1..MaxIength] of char; {Word to permute} 
Wordlength : integer; {Length of Word} 

Probability : array [0..26,0..26,0..26] of integer; 
ScoreBoard : array [1..MaxScores] of ScoreLine; 
WordToScore : strlng[MaxIength]; {anagram} 

DataFile : file of integer; {probability table} 

TheWord : String[MaxIength]; {Word as string} 

I : Integer; {counter} 


procedure Score; 
var 

X,Y,Z,I,J : Integer ; 
Total : integer ; 
Unlikelihood ; integer; 


procedure KeepScore; 


( continued ) 
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var 

N : integer; 

procedure ChalkltUp; 
var 

TempScore, I : integer; 

TempName : StrIng[MaxLength]; 

begin {ChalkltUp} 

for I :■ N to MaxScores do 
begin 

with ScoreBoard[I] do Ilf an anagram} 
if Total>Polnts then {scores better,} 

begin {then record it...} 

begin 

TempScore :* Points; 

TempName :■ Winner; 

Points :■ Total; 

Winner :* WordToScore 

end; 

if IoMaxScores then 

begin {..bump the rest down} 
with ScoreBoard[I+1] do 
beg i n 

WordToScore :« TempName; 
Total :* TempScore; 

end; 

end; 

end; 

end; 

end; {ChalkltUp} 


begin {KeepScore} 

for N :• 1 to MaxScores do 
begin 

if WordToScore - ScoreBoard[N].Winner 

then Total ;■ 0; {eliminate duplicates} 
if (Total > ScoreBoard[N].Points) 
then ChalkltUp; 

{record good-scoring words} 

end; 

end; {KeepScore} / 


begin {procedure Score} 

WordToScore :■ • * + WordToScore + * ’; 
Total :» 0; 

Unlikelihood :« 0; 

for I := 1 to Iength(WordToScore) -2 do 
begin 

X ord(copy(WordToScore,I,1))-64; 

Y :■ ord(copy(WordToScore,1+1,1))-64; 
Z :* ord(copy(WordToScore,1+2,1))-64; 
If X<0 then X:=0; 

If Y<0 then Y:=0; 
if Z<0 then Z:«0; 


Total Total + Probabillty[X,Y,Z]; 

If ProbabiI Ity[X,Y,Z]=0 then Unlikelihood :* succ(UnI ike Iihood) 

end; 

for J := 1 to Unlikelihood do Total Total div 2; 

KeepScore; 

end; {procedure Score} 


procedure Permute (CurrentLength : integer); 


var 

I : Integer; 

procedure Switch; 
var 
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Temp : char; 
beg i n 

Temp :* Word[CurrentLength]; 
WordTCurrentLength] :* Word[I]; 
Wordfl] :■ Temp; 
end; {Switch} 


procedure Outword; 
begin 

WordToScore*; 
for I :* 1 to Wordlength do 
WordToScore :* WordToScore + Word[I]; 
end; {Outword} 

begin {Permute body} 

if CurrentLength « 1 
then begin 

Outword; 

Score; 

end 

else for I :« 1 to CurrentLength do 
begin 

Switch; 

Permute(CurrentLength - 1); 
Switch; 

end; 

end; {Permute} 


procedure Getlnput; 
var 

I ; integer; 
begin 

write('Enter word: '); 
readln(TheWord); 

WordLength :« Iength(TheWord); 
for I :* 1 to WordLength do 
begin 

Word[I] :« upcase(copy(TheWord,1,1)); 

end; 

TheWord :« 

for I :» 1 to WordLength do 

TheWord TheWord + Word[I]; 

end; {procedure Getlnput} 

procedure ZeroScore; 
var I : integer; 

begin 

for I:« 1 to MaxScores do 
beg i n 

with ScoreBoardfl] do 
begin 

Points :* 0; 

Winner :■ M ; 

end; 

end; {withj 
end; {ZeroScore} 


procedure PostScore; 
var 

I ; integer; 

Gotlt : boolean; 

begin 

GotIt:*false; 

for I :■ 1 to MaxScores do 


( continued ) 
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begin 

with ScoreBoard[I] do 
begin 

If Polnte>0 then 

wr J teIn(1:2, • ’.Winner, 1 ’, Points); 

end; {with} 
end; jfor loop} 
end; {procedure PostScore} 

procedure ReadProb; 

var X,Y,Z : Integer; 

beg I n 

asslgn(Dataf1 Ie,’PROB.DAT’); 
reset(DataFIle); 
for X :« 0 to 26 do begin 
wr I te(•*•); 

for Y :■ 0 to 26 do begin 

for Z ;■ 0 to 26 do begin 

read(DatafIle.ProbabiIity[X,Y,Z]); 

end; 

end; 

end; 

close(DatafIle); 
wr IteIn; 

end; {procedure ReadProb} 


procedure SlgnOn; 
beg i n 

c I rscr; 

wrIteInf’Anagram.Pas *); 
wr I teIn(’By Bob Keefer’); 
wr 11 eIn(’CopyrIgh t 1985'); 
wr IteIn; 
wr IteIn; 

writeln(’To halt program, enter "*"’); 
wr l teIn; 
wr I teIn; 
wr IteIn; 

writeln(’Reading Probability Table...*); 
end; {procedure Signon} 


begin 


end. 


{Anagram program} 

SignOn; jDIsplay signon message} 

ReadProb; {Read probability table} 

c I rscr; 
repeat 


Get Input; 

ZeroScore; 

Permute (WordIength); 
wr iteln; 

PostScore; 
wr I teIn; 
wr I teIn; 

untiI Word[1]-’*’; 


i Get word} 
clear Scoreboard} 
{Evaluate words} 

{Print resuIts} 


setprob.pas 

Programming Project: "Anagram Solving in Pascal," by 
Bob Keefer. July, page 113. Also see anagram.pas. 

Keywords: JUL86 Programming Project anagram Pascal Bob Keefer 


program SetProb; 

{Copyright 1985 by Bob Keefer} 

{SetProb.Pos creates a 3-dimensional byte 
array, ProbobiIity[X,Y,Z]. In which are stored 
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the relative probability of each 3-letter 
trigram found in an input text. 

Once the table is completed, it is stored in 
the disc file PROB.DAT.} 

{To use this program to add more data to an 
existing version of PROB.DAT, modify procedure 
ZeroProb so that it reads ProbabiIity[X,Y,Z] 
from PROB.DAT instead of zeroing the array. 
This can be done by commenting out the lines 
marked with a single * and restoring the lines 
marked with a double **.} 


var 

Chi, Ch2, Ch3 : char; 

X, Y, Z : integer; 

FiIename : str1ng[15]; 

TheFiIe : text; 

Datafile : file of integer; 

Probability : array [0..26,0..26,0..26] of integer; 
procedure ZeroProb; 
var 

X,Y,Z : integer; 
begin 

{assign (Dataflie,'Prob.dat *);} {**{ 

{reset(Datafile);} {**} 

for X:»0 to 26 do begin 

for Y:*0 to 26 do begin 

for Z:* 0 to 26 do begin 

{*} Probab!Iity[X,Y,Z] :* 0; 

{**} {read(DatafiIe,ProbabiIity[X,Y,Z]);} 

end; 

end; 

end; 

{close (Datafile);} {**} 
end; {ZeroProb} 


procedure ScaleProb; 
var 

X,Y,Z : integer; 


begin 

for X:*0 to 26 do begin 

for Y:»0 to 26 do begin 

for Z:» 0 to 26 do begin 
Probab!Iity[X,Y,ZJ :« 

(Probab!Iity[X,Y,Z] + 1) 
div 2; 

end; 

end; 

end; 

end; {ScaleProb} 


procedure Startup; 

begin 

c I r s c r * 

writeIn('SetProb.Pas *); 
wrlteln(*Copyright 1985 by Bob Keefer*); 
wr i teln; 

write (’Enter filename: *); 
read In (F 1 Iename); 
assign (TheFlIe, Filename); 
reset (TheFlie); 
end; 


[continued) 
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function Cleanup ( A : integer ) : integer; 
beg i n 

If (A>64) and (A<91) then Cleanup :■ A-64 
else Cleonup :■ 0; 
end; {function Cleanup} 


procedure Countem; 
begin 

Chi #32; 

Ch2 :• #32; 

while not EOF (TheFIle) do 
beg i n 

read(TheFiIe,Ch3); 

X :■ CleanupfordfupcasefChl^}; 

Y :■ CIeanup(ord(upcase(Ch2))); 

Z :« Cleanup(ord(upcase(Ch3))); 

if not (((X=0) and (Y-0)) or 
((Y=0) and (Z=0))) 
then ProbabiIity[X,Y,Z] 

ProbabiIity[X,Y,Z] + 1; 
if Probabi11ty[X,Y,Z] >32000 then ScaleProb; 
Ch1:«Ch2; 

Ch2:«Ch3; 

end; 

end; {Countem} 

procedure WrlteData; 
var X,Y,Z ; Integer; 
begin 

for X ;« 0 to 26 do begin 

for Y :■ 0 to 26 do begin 

for Z ;■ 0 to 26 do begin 

write(Datafile,ProbabiIlty[X.Y,Z]); 

end; 

end; 

end; 

end; {procedure WrlteData} 


begin {program SetProb} 

ZeroProb; 

Startup; 

Countem; 

assign(DatafIle,’Prob.dat’); 
rewrite(Dataflie); 

Wr1teData; 
closefDataFile); 
cIose(TheFlie); 
wr1te(#7); 

end. 


chkup.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE CHKDUP - SUBROUTINE TO CHECK FOR DUPLICATED LINES 
PAGE ,132 


; (C) Copyright 

COMMENT * 

Mode of 

where 

* 


Microstress Corporation 1984, 1985, 1986 


use: 

call CHKDUP (number,fIag) 

number « integer with the element number to check, 
flag * integer to show success («0) or error (=1). 
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SUBTTL 

FORMAL 

DECLARATIONS 

PAGE 

cschdp 

SEGMENT 

*CODE * 

ASSUME 

CS:cschdp 

tab 1 e 

db 

150 dup (0) 

masks 

db 

1,2,4,8,16,32,64,128 

SUBTTL 

CHKDUP 

- EXECUTABLE CODE 

PAGE 

PUBLIC 

CHKDUP 


CHKDUP 

PROC 

FAR 


PUSH 

BP 


MOV 

BP,SP 


push 

ds 


LDS 

BX,DWORD PTR [BP+10] 


MOV 

ax,[BX] 


push 

ds 


mov 

bx,cschdp 


mov 

ds, bx 


cmp 

ax,0 


J« 

reset 


dec 

ax 


xor 

dx.dx 


mov 

bx,8 


dl v 

bx 


mov 

bx,offset masks 


add 

bx,dx 


mov 

ch,[bx] 


mov 

bx,offset table 


add 

bx,ax 


mov 

Cl ,[bx] 


push 

cx 


and 

cl ,ch 


cmp 

cl ,0 


Jne 

error 


pop 

cx 


or 

cl ,ch 


mov 

[bx],c1 


xor 

ax, ax 


Jmp 

exit 

error: 


pop 

cx 


mov 

ax, 1 


Jmp 

exit 

reset: 


mov 

bx,offset table 


mov 

cx,150 

byte loop: 



mov 

[bx],a 1 


inc 

bx 


loop 

byte loop 

exit: 


pop 

ds 


LDS 

BX,DWORD PTR [BP+6] 


mov 

[bx],ax 


pop 

ds 


MOV 

SP,BP 


POP 

BP 


RET 

8 

CHKDUP 

ENDP 


cschdp 

ENDS 


END 
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date.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE DATE 
PAGE ,132 


SUBROUTINE TO GET THE DATE 


; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * 

DATE Is a routine designed to be called from FORTRAN as a subroutine 
to access the date from the system. 



Mode of 

use: 



call DATE (day,month 


where 




day « 2-byte Integer containii 



month * 2-byte integer contali 


♦ 

year * 2-byte integer contain 

SUBTTL 

FORMAL DECLARATIONS 

PAGE 



csdate 

SEGMENT 

'CODE * 


ASSUME 

CS:csdate 

SUBTTL 

DATE - EXECUTABLE CODE 

PAGE 



PUBLIC 

date 


date 

PROC FAR 


PUSH 

BP 


MOV 

BP.SP 


PUSH 

DS 

; Call 

the system function. 


xor 

ax, ax 


mov 

ah,2Ah 


Int 

21h 

; Handle parameters from calling program 


LDS 

BX,DWORD PTR [BP+6] 


MOV 

[BX],cx 


xor 

ax, ax 


mov 

a 1 ,dh 


LDS 

BX,DWORD PTR [BP+10] 


MOV 

[BX],ax 


mov 

a 1. d 1 


LDS 

BX,DWORD PTR [BP+14] 


MOV 

[BX],ox 

; Everything done except housekeeping. 

exit: 




POP 

DS 


MOV 

SP, BP 


POP 

BP 


RET 

0Ch 

date 

ENDP 


csdate 

ENDS 


END 



upcstr. 

.asm 



"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE UPCSTR - SUBROUTINE TO PUT A STRING IN UPPERCASE 
PAGE ,132 
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COMMENT * 

UPCSTR is a routine designed to be called from FORTRAN as a subroutine 
to set all the alphabetic characters to uppercase. 


Mode of use: 
where 

string 


♦ 


call UPCSTR (string) 

name of the string (variable of type CHARACTER) to be 
converted to uppercase. 


SUBTTL FORMAL DECLARATIONS 
PAGE 


csupcs SEGMENT ’CODE’ 

ASSUME CS:csupcs 

SUBTTL UPCSTR - EXECUTABLE CODE 
PAGE 


PUBLIC 

UPCSTR 



UPCSTR 

PROC 

FAR 




PUSH 

BP 




MOV 

BP,SP 




PUSH 

ds 




LDS 

BX,DWORD 

PTR 

[BP+6] 

character: 




CMP 

BYTE 

PTR 

[bx],0 


Je 

exit 



CMP 

BYTE 

PTR 

[bx],6 


je 

exit 




CMP 

BYTE 

PTR 

[bx],*o 


JB 

next 



CMP 

BYTE 

PTR 

[bx],-z 


JA 

next 



AND 

BYTE 

PTR 

[bx],95 

next: 

INC 

bx 




Jmp 

character 


exit: 

pop 

ds 




MOV 

SP.BP 




POP 

BP 




RET 

4H 



UPCSTR 

ENDP 




csupcs 

ENDS 




END 






safe2sub.for 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


$LINESIZE: 132 
$PAGESIZE: 61 
$ST0RAGE: 2 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
£ c 

c MICROSAFE C 

C Structural Analysis by Finite Elements C 

C Module : SAFESOLV, 2nd Part C 

C Version : 2-D C 

C C 

C COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986 C 

C ALL RIGHTS RESERVED C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 


(continued) 
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SUBROUTINE parsfn (fI spec,ddrIve,fI dr Iv,dr Iven,fI path,fIname, 

+ flextn) 

Parse a file specification and get drive, path, name and extension 
IMPLICIT INTEGER (a-z) 

CHARACTER fI drI v*6,fIpath*64,fIname*9,fIextn*5,fIspec*78,coIon*2, 
+ bsIash*2,period*2 

Initial Ization. 


call setstr (78,flspec) 
caI I pakstr (fI spec) 


caI I upcstr (fI spec) 
fldrlv-' 

cal I setstr (6,fldrlv) 
f I path-* 

+ * 

cal I setstr (64,fIpath) 
flname-' ' 

cal I setstr (9,fIname) 
flextn-' 

caI I setstr (5,fIextn) 
colon-': ' 

caI I setstr (2,coIon) 
bslash«'\ * 

cal I setstr (2,bsI ash) 
period-'. ' 

cal I setstr (2,period) 

Determine the drive specification 

locatn-locstr (1,fI spec,coI on) 

If (locatn .eq. 0) then 
dr I ven-ddrive+1 

e I se 

call movstr (fI dr Iv,1,1,fI spec,1,locatn) 
drIven-ascstr (locatn-1,fIspec)-64 
end! f 

Determine the path specification 

f I rstc-locatn+1 
I astoc-locatn 

10 locatn-locstr (Iastoc+1,fI spec,bsI ash) 

If (locatn .ne. 0) then 
lastoc-locatn 
goto 10 

e I se 

call movstr (fI path,1,1,fI spec,fIrstc,Iastoc-fIrstc+1) 
end! f 

Determine the extension specification 

length-1enstr(fI spec) 

locatn-locstr (Iastoc+1,fI spec,period) 

If (locatn .ne. 0) then 

cal I movstr (fIextn,1,1,fI spec,locatn,Iength-1ocatn+1) 

e I se 

locatn-Iength+1 


endi f 


Determine the name spec 

ca11 movstr (f1 name, 

Pack the return 

strings 

ca11 pakstr i 
ca11 pakstr < 
ca11 pakstr < 
ca11 pakstr i 
RETURN 

END 

ffIdriv) 
f f 1 path) 
[ f 1 name; 
[f1extn) 



$PAGE 


14 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 






o o o 


J uly 


c 

c 

c 


SUBROUTINE trlasemb (i,j,k,th,eyoung,prat Io) 
Assemble stiffness matrix for triangular plate 


DOUBLE PRECISION th,diffnc(2,4),ftcons(9),eyoung,pratio 
common /coordi/ coonod(2,401) 
d j ffnc{1 »2)*coonodf 1, J^-coonodM , I 
~,2)-coonod(2,J)-coonod(2,I 
coonodf1,K)-coonod(1,J 
coonod(2,K;-coonod(2,J 
coonod(1,I)-coonod(1,K) 

• K) 


diffnc(2 
diffnc(1,3 
dlffnc(2,3 

diffncf 1,1 _ . _ 

diffnc(2,1)*coonod(2,I;-coonod(2 


ftcons 
ftcons 
ftcons 
ftcons 


diffnc(2,3)*diffnc(1,2)-diffnc(1,3)*diffnc(2,2) 
eyoung*TH/(4*ftcons(6)) 


»ftcons 
■ftcons 


1)/(l-pratio 
u/U+prat Io 


! 


ftcons(1)«ftcons(7)♦ 

+ (dlffnc(1,3)*dlffnc(1,3)+diffnc(2,3)*diffnc(2,3)) 

ftcons(2)-ftcons(7)* 

+ (dlffnc(1,1)*diffnc(1,1)+dlffnc(2,1)*dlffnc(2,1)) 

ftcons(3)-ftcons(7)* 

+ (dlffnc(1,3)*dlffnc(1,2)+diffnc(2,3)*dt ffnc(2,2)) 

ftcons ( 4J-ftcons(7}*ftcons(6) 
ftcons(5)«ftcons(7)* 

(diffnc(1,2)*dlffnc(1,2)+diffnc(2,2)*diffnc(2,2)) 


$PAGE 


11-3*1-2 
J1«3*J-2 
K1-3*K-2 

CALL assemble (11,11,ftcons(1)+ftcons(8)*diffne(2,3)*diffnc(2,3), 
+ -ftcons(8)*dlffnc(1,3)*diffnc(2,3),0.) 

CALL assemble (11.J1,-ftcons(1)-ftcons(3)+ 

+ ftcons(8)*diffnc(2,3)*dlffnc(2.1), 

+ _ . -ftcons(4)-ftcons(8)*dlffnc(2,3)*diffnc(1,1),0.) 

CALL assemble (11,k1,ftcons(3)+ftcons(8)*diffnc(2,2)*diffnc(2,3), 
+ ftcons(4)-ftcons(8)*dIffnc(2,3)*diffnc( 1 , 2 ), 0 .) 

CALL assemble (11 + 1,11 + 1,ftcons(1)+ 

+ ftcons(8)*diffnc(1,3)*diffnc(1,3),0.,0.) 

CALL assemble (11 + 1,J1,ftcons(4)-ftcons(8)* 

+ dlffnc(2,1)*diffnc(1,3),-ftcons(1)-ftcons(3)+ 

+ ftcons(8)*dlffnc(1.1)*dlffnc(1,3),0.) 

CALL assemble (I1+1.K1, 

+ -ftcons(4)-ftcons(8)*dlffnc(2,2)*diffnc(1,3), 

+ _ ftcons(3)+ftcons(8)*dlffnc(1,2)*diffnc(1,3),0.) 

CALL assemble (J1,J1,ftcons(2)+ftcons(8)*dlffnc(2,1)*dlffnc(2,1) 

+ -ftcons(8)*dI ffnc(2,1)*diffnc(1,1),0.) 

CALL assemble (J1,K1,-ftcons(3)-ftcons(5)+ 

+ ftcons(8)*dIffnc(2,1)*dlffnc(2,2), 

+ , -ftcons(4)-ftcons(8)*dIffnc(2,1)*dlffnc(1,2),0.) 

CALL assemble (J1+1.J1+1, y ' 

+ ftcons(2)+ftcons(8)*d!f fnc(1,1)*dlffnc(1,1),0..0.) 

CALL assemble (J1+1,k1,ftcons(4)- ' 

+ ftcons(8)*dlffnc(1,1)*diffne(2,2),-ftcons(3)- 

+ ftcons(5)+ftcons(8)*dlffnc(1,1)*diffnc(1,2),0.) 

CALL assemble (K1,K1,ftcons(5)+ftcons(8)*diffnc(2.2)*diffnc(2,2) 

+ -f tcons(8)*diffnc(1,2)*dlffnc(2,2),0.) 

CALL assemble (k1+1,k1+1, 

* rTIIDll ftcons(5)+ftcons(8)*diffnc(1,2)*dlffnc(1,2),0.,0.) 

RETURN 
END 


SUBROUTINE assemble (irow,icoI,addl,add2,add3) 
Assemble the stiffness matrix 


DOUBLE PRECISION stmtrx,stmqcn,add(3),addl,add2,add3 
INTEGER long I*4 

COMMON /global/ numdof,stmqcn(2,2) 

common /sizebw/ malhbw 

COMMON /aaaaaa/ stmtrx(8200) 

add(1)«add1 

addf2)«add2 

add(3)«add3 

do 10 1-1,3 

If (add(l) .ne. 0.) then 
ic-icol+l-1 

If ((Irow .Is. numdof) .and. (Ic .Is. numdof)) then 
longl-ic+Irow-1-malhbw 


{continued) 
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If (Irow .ge. Ic) then 
IongI-IongI+maIhbw*Ic 

e I ee 

IongI-1ong!+maIhbw*I row 
endlf 

stmtrx(IongI)-stmtrx(IongI)+add(l) 

else 

IongI«ic+ frow-2-numdof 
If (Irow .gt. numdof) then 
If (Ic . le. numdof) then 

longi«longI+Ic*(malhbw+1) 
stmtrx(IongI)«stmtrx(IongI)+add(I) 

e I se 

Ir-Irow-numdof 
Icband-!c-numdof 

stmqcnf!r,Icband}-stmqcn(Ir,Icband)+add(I) 
stmqcn(Icband,Ir)-stmqcn(I r, Icband) 
endlf 

e I se 

IongI-IongI+1row*(maIhbw+1 ) 
stmtrx(Iongl)-stmtrx(Iongl)+add(l) 
endlf 
endl f 
END IF 

10 continue 
RETURN 
END 

$PAGE 

SUBROUTINE trlloads (Inpl,lnp2,lnp3,th.eyoung.pratlo,Ip I.nodepl) 
Calculate forces and stresses In triangular plate 


DOUBLE PRECISION disdof,cor for,eyoung,pratlo,th, 

+ diffnc(2,4),ftcons(9) 

DIMENSION lnp(3),cor for(2,3).nodepl(4,500) 

INTEGER prevld 

common /coord!/ coonod(2,401) 

COMMON /plates/ disdof(1203),pltecf(2,4),pIstrs(3,500), 

+ reafor(3.400),pstnor(3,400),pstacc(3,400) 

prevldfk,I)*M0D(k+l-2,I)+1 
next Id(k,I)-MOD(k, I )+1 
Inp(1)«Inp1 
Inp(2)-Inp2 
Inp(3)-inp3 
I»nodepl(inp(1).LPL) 

J-nodepI(inp(2),LPL) 

IF (lnp(3) .It. 0) THEN 
K—i np(3) 
nan-2 


ELSE 

K-nodepI(lnp(3),LPL) 
nan-3 


ENDIF 

11-3*1-2 

J1»3*J-2 

K1-3*K-2 

dl f fnc(1,2)-coonodM , J}-coonod(1 , I} 
dlffnc(2,2)«coonod(2,j)-coonod(2,I ) 
dlffnc(1,3)«coonodM,K)-coonod(1, j) 
diffnc(2,3)-coonod(2,K)-coonod(2,J) 
dlffncCI,1)«coonod(1,l)-coonodf1,lO 
diffnc(2,1)«coonod(2,I)-coonod(2,K) 

ftcons(4)«eyoung/((1+pratIo)*(dIffnc(1,1)*diffnc(2,2)- 
+ diffnc(1,2)*diffnc(2,1))) 

ftcons(5)-dIffnc(2,3)*disdof(I1)+diffnc(2,1)*disdof(J1)+ 

+ diffnc(2.2)*disdof(K1) 

ftcons(6)-diffnc(1,3)*disdof(11+1)+diffnc(1,1)*disdof(J1+1)+ 
+ dlffnc(1,2)*disdof(K1+1) 

f tconsM ^-(prat Io*f tcons(6)-ftcons(5^*f tcons(4Vp“P r at io) 
ftcons(2;=(ftcons(6)-pratio*ftcons(5;)*ftcons(4)/(1-pratio) 
ftcons(3)-(diffnc(1,3)*disdof(II)-diffnc(2,3)*disdof(11+1)+ 

+ diffnc(1.1)*disdof(J1)-diffnc(2,1)*disdof(J1+1)+ 

+ diffncM,2)*disdof(K1)-dlffnc(2.2)*disdof(K1+1))* 

+ ftcons(4)/2 

DO 20 LL-1.NAN 
INDX-nodepI(Inp(LL),LPL) 
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ftcons(7)-ABS(dif fnc(2,nextid(LL,3))-dl ffnc(2,LL))/ 

+ (ABS(d ? f fnc(l,next id(LL,3))-diffnc(1,LL))+ 

+ ABS(diffnc(2,nextid(LL.3))-diffnc(2.LL))) 

DO 10 L-1,2 " 

corfor(L,LL)-TH*.5*(diffnc(1,previd(LL,3))*ftcons(4-L)- 
+ diffnc(2,previd(LL,3))*ftcons(2*L-1)) 
pi tecf(L,lnp(LL))»pltecf(L,inp(LL))+corfor(L,LL) 
ftcons(7)«1-ftcons(7) 

reafor(L,INDX)-reafor(L.INDX)+corfor(L,LL) 
pstnor(L,INDX)=pstnor(L,INDX)+ftcons(7) 
pstacc(L,INDX)-pstacc(L,INDX)+ftcons(7)*ftcons(L) 

10 CONTINUE 

pstacc(3,INDX)-pstacc(3,INDX)+ftcons(3) 
pstnor(3,INDX)*pstnor(3,INDX)+1 
pIstrsCLL.LPLJspIstrsCLL.LPLJ+ftcons(LL) 

20 CONTINUE 

IF (nan .EQ. 2) pIstrs(3,LPL)=pIstrs(3,LPL)+ftcons(3) 

RETURN 

END 

$PAGE 

SUBROUTINE opnfil (lerror) 

C 

C Open a file for output with verification 
C 

LOGICAL ffound 

CHARACTER inpfil*78,outfI I*78,prompt*55,intgst*25 
common /filenm/ InpfiI,outf11 
inquire (FILE=outfII,EXIST-ffound) 

If (.not.(ffound)) then 

cal I setstr f78,outf11) 
cal I pakstr (outf11) 
length*lenstr(outfI I)+1 
cal I expstr foutf11 ) 
cal I resstr foutfI I) 
call setstr (length,outfil) 
call chopwr (outfiI,lerror) 

If (lerror .ne. 0) then 
cal I resstr (outfI I) 
length-length-1 

call wrfstr (float(length),Intgst) 
length-lenstr (Intgst) 

prompt-* (• * ERROR : File H *\a , * *" cannot be open. Try a 
+galn.* *) * 7 

call setstr f55,prompt) 
call movstr (prompt,21,0,Intgst,1,Iength) 
caI I resstr (prompt) 
write (*,prompt) outfil 
return 
endif 

cal I resstr (outf11) 
endi f 

OPEN (2,FILE«outfI I,STATUS-*new*) 

lerror-0 

return 

END 

$PAGE 

SUBROUTINE diskroom (nbytes) 

C 

C Update count of characters in output file to avoid disk full errors. 

C 

INTEGER frespc*4,odrIve.scrflg,asclIc 
COMMON /dskrom/ scrfIg,odrIve 
C 

if (nbytes .eq. 0) then 

call dskspc (odr1ve,frespc) 
frespe-frespc-1 

e I se 

C 

20 frespe-frespe-nbytes 
C 

If (frespc .It. 0) then 
close (2) 
asciIc-odrlve+64 
write (*,30) 

30 format (//* ERROR : Output file disk Is full.*) 


(continued) 
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32 

35 


40 


write (*,35) char(ascMc) 
format (’ Change the disk In drive *,a1, 
h * and press any ke to continue.*) 

cal I confrm 

If (scrflg .eq. 0) write (*,40) 

format (1x\) 

caI I opnfI I ( I error) 

If (lerror .ne. 0) goto 32 
call dskspc (odrIve,frespc) 
frespc-frespc-1 
goto 20 
endl f 
endl f 
return 
end 


$P AGE 


SUBROUTINE verify (Id IIne,entry,Ierror,maxban.youngm) 
Verify Input data 


Implicit Integer (a-z) 

reaI coonod,entry,boulow,bouhlg,ftcons,fItstr,youngm 

CHARACTER buffer*126,slash*2,space*2,stcons*25,Iine*79,InpfI 1*78, 

+ outfI I*78,per Iod*2,grafch*1,tabchr*2,typpar*14,ordin1*8, 

+ errmsg*50,IIntyp*16,IInent*30,txtpar*49,messge*80 

DIMENSION numpar(14),Itypar(14,8),bouIow(14,8),bouhia(14,8), 

+ Itxtpr(14,8),typpar(2),errmsg(9),Iintyp(14),Iinent(14), 

+ ordlnI(8),txtpar(40),messge(3),entry(8),youngm(20) 

common /coordl/ coonod(2,401) 
common /slzebw/ malhbw 
common /filenm/ InpfI I,outfII 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c 

C ARRAY INITIALIZATION 

C 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
DATA numpar /I,1,1,1,1,1,1,3,3,8.7,5,4,3/ 

DATA ltypar /14*1,9*2,3*1,2,1,9*2,3*1,2,1,10*2,1,3*2,10*2,1,3*2, 

+ 10*1,4*2.10*2.4*1,14*2/ 

DATA boulow /I.,6*0.,7*1.,8*-10E18,0.,3*1..-10E18,1.,8*-10E18, 

+ 0..3*1.,2*-10E18,10*0.,1.,0.,2*-10E18,14*0.,10*1., 

+ 4*0.,10*-10E18,4*1.,14*-10E18/ 

DATA bouhIg /400.,20.,600.,500..60.,100.,300.,7*0..13*10E18,3., 

+ 14* 10E18,14* 10E18,14* 10E18,14* 10E18,14* 10E18, 

+ 14*10E18/ 

DATA typpar /’ - an Integer *,* - a number ’/ 

DATA errmsg /’UNEXPECTED END OF INPUT FILE. 


+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

D 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 


,* INPUT LINE CONTAINS LESS DATA THAN REQUIRED. 

,’ENTRY CANNOT BE INTERPRETED AS A NUMBER. 
.’INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE. 
.’ENTRY IS OUTSIDE THE PROPER NUMERIC BOUNDS. 

,’THE STIFFNESS MATRIX BAND IS TOO WIDE. 

,’ELEMENT WITH TWO IDENTICAL NODES. 

.’ELEMENT NODES SHARE THE SAME PHYSICAL LOCATION. 

,’DUPLICATED SPECIFICATIONS IN INPUT FILE. 


DATA llntyp /’model size 
,’mode I size 
,’mode I size 
,’mode I size 
,’mode I size 
,’mode I size 
,’mode I size 
,’node 
,’mater I a I 
,* beam 
,’pI ate 
,’fastener 
,'nodal loading 
,*nodaI restraInt 


DATA llnent /’ 


+ 

+ 

+ 

+ 

+ 

+ 
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+ 

+ 

+ 

+ 

♦ 

+ 

+ 

DATA ordlnl 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

DATA Itxtpr 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

stcons-* 

IIne-' 

+ 

slash-’/ * 
cal I setstr(2,slash) 
space-* * 

cal I setstr(2,space) 

grafch-char(9) 

tabchr-' * 

cal I setstr(2,tabchr) 

cal I movstr(tabchr,1,0,grafch,1,1) 

chrerr-0 

idparm-1 

locatn-1 

If (Idllne .eq. 1) linumb-0 
10 IInumb-IInumb+1 
I error-1 

READ (1.20,END-70, ERR-1000) buffer 
20 FORMAT (A126) 

cal I setstr(126,buffer) 
ierror-0 

ENDSEP-locstr(1.buffer,sI ash) 

IF (ENDSEP .eq. 0) goto 10 
call endstr (endsep+1.buffer) 

25 Itcons-locstr(Iocatn.buffer,tabchr) 

If (Itcons .ne. 0) then 

call movstr (buffer,Itcons,0,space,1,1) 
locatn-ltcons+1 
goto 25 
endl f 
locatn-1 

30 IF (Iocatn .ge. ENDSEP) THEN 
chrerr-ENDSEP 
lerror-2 
GOTO 70 
endl f 

seprtr-loc8tr(Iocatn,buffer.space) 

IF (seprtr .eq. locatn) THEN 
locatn-locatn+1 
GOTO 30 
endl f 

IF ((seprtr .eq. 0) .OR. (seprtr .gt. ENDSEP)) seprtr-ENDSEP 

lerror-0 

decpop-0 

EXPFLG-0 

EXPSGN-0 

seploc-seprtr-locatn 
do 50 posItn-1.SEPLOC 
Index-locatn+positn-1 
asclic-ascstr(Index,buffer) 

IF ffascllc .gt. 47) .AND. (ascllc .It. 58)) goto 40 
IF ((posItn .eq. 1) .AND. ((ascllc .eq. 43) .OR. 


,'coordinates of node * 

,'properties of material code ’ 

,'properties of beam • 

,'properties of plate • 

,'properties of fastener ' 

,'applied loads to node * 

,'Imposed displacements to node '/ 

/'first 

.'second ' 

.'third 
,'fourth * 

.'fifth 
,'sixth 
.'seventh ' 

.'eighth '/ 

/I.2,3.4.5,6.7,8,11.14,22,29.34.38, 
0,0,0,0,0,0.0,9,12,15.23.30,35,39, 
0,0,0,0,0,0,0,10.13,16.24.31,36,40, 
0.0.0,0,0,0,0,0,0,17.25,32,37.0, 
0,0,0,0,0,0,0,0,0.18.26,33,0.0, 
0,0,0,0.0,0,0,0,0,19,27,0,0,0, 
0,0,0,0,0,0,0,0,0,20,28,0.0.0. 
0,0,0,0.0.0.0,0,0,21,0,0.0,0/ 


( continued ) 
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IF 


! asdic .eq. 45))) goto 40 
(asdic .eq. 46) .AND. (decpop .eq. 0)) THEN 
decpop-Iocatn+posItn-1 
GOTO 40 
endi f 

IF (((asdic .eq. 68) .OR. (asdic .eq. 69) 

+ .OR. (asdic .eq. 101)) .AND. (EXPFLG .eq. 
EXPFLG-Iocatn+posltn 
GOTO 40 
endi f 

IF (((asdic .eq. 43) .OR 


.OR. 

0 )) 


(asciic 
THEN 


.eq. 100) 


THEN 


40 

50 

60 


.AND. (EXPSGN .eq. 0)) 

EXPSGN-Iocatn+pos1tn 
if (asdic .gt. 43) expsgn—expsgn 
GOTO 40 
endi f 
Ierror-3 

chrerr-Iocatn+positn-1 
goto 60 
continue 
continue 
continue 
IF (terror 
cal I setstr( 
caI I movstr( 
ca11 resstr( 


(asdic .eq. 45)) .AND. (EXPFLG .ne. 0) 


70 


.eq. 3) goto 
(25,stcons) 

(stcons,1,1,buffer,locatn,SEPLOC) 
(stcons) 

ftcons-f1tstr(stcons) 

IF ((ftcons .It. boulow(ldline,idparm)) .OR. 
+ (ftcons .gt. bouh!g(idlIne,Idparm))) THEN 
ierror-5 
chrerr-locatn 
GOTO 70 
endi f 

IF ((Itypar(IdlIne,idparm) .eq. 1) .and. 

► (ftcons .ne. float(Int(ftcons)))) then 
Ierror-4 

IF (decpop .ne. 0) THEN 
chrerr-decpop 
GOTO 70 

ELSE 

IF (EXPSGN .It. 0) THEN 
chrerr—EXPSGN 
GOTO 70 

ELSE 

chrerr-locatn 
GOTO 70 
endi f 
end! f 
end! f 

entry(1dparm)-ftcons 
If ((Idparm .eq. 1) , 


then 

Itcons«INT(ftcons) 

CALL CHKDUP (Itcons,I error) 
IF (terror .ne. 0) THEN 
Ierror-9 
chrerr-locatn 
goto 70 
end I f 


and. (IdlIne .gt. 7) .and. (idlIne .It. 14)) 


e I se 

If ((idparm .ea. 2) .and. (idl!ne .eq. 
itcons»INT(3*entry(1)+ftcons-3) 
CALL CHKDUP (Itcons,I error) 

IF (ierror .ne. 0) THEN 
ierror-9 
chrerr-locatn 
goto 70 
endi f 
endi f 
endi f 

locatn«seprtr+1 
idparm*idparm+1 
IF (idparm .gt. 
if (idline 
if (idline 


14)) then 


numpar(idline)) THEN 

6) bouhig(ldline+7,1)=entry(1) 


It 

eq. 


?s 


then 


bouhig(10,2)»entry(1) 
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+ 

+ 


+ 


+ 

+ 

♦ 


♦ 


65 


bouhigf 10,3)«entryM ) 
bouhlg(l1,2)«entry(1) 
bouhigf11,3)»entryf1} 
bouhlgill,4)-entryf1) 
bouh igi 11,5 Wont ryi 1) 
bouhig(12,2)-entry(1) 
bouh I gf 12,3gentryf 1 ) 
bouh1gi13,1)-entry(1) 
bouhlg(l4,1)«entry(1) 
end! f 

If (IdlIne .eq. 2) than 
bouhIg(10,6)«entry(1) 
bouhigf11,7)«entry(1) 
and! f 

If (((idline .eq. 10) .and. (entry(4} .na. 0.) .and. 
(youngm(1nt(antry(6))) .na. 0.)) .or. 

((fdIIna .aq. 12) .and. (entry(5) .na. 0.))) than 

nod1«Int(entry(2n 

nod2-int(entry(3)) 

Ibanwd«3*(1+abs(nod1-nod2)) 

If (Ibanwd .gt. malhbw) then 
lerror-6 
goto 70 

a I sa 


If (Ibanwd .aq. 3) then 
lerror-7 
goto 70 
end! f 
endi f 

If (IdlIna .aq. 10) than 

If (fcoonodfl ,nod1 ) .eq. 
(coonod(2,nod1) .eq. 
i error-8 
goto 70 
end! f 
endi f 

If (Ibanwd .gt. maxban) maxban 


coonodf1,nod2}} .and. 
coonod(2,nod2))) then 


'Ibanwd 


else 

If (fidltne .eq. 11) .and. (entry(6) .na. 0.) .and. 
(youngm(!nt(entry(7))) .na. 0.)) than 
maxnod-max(int(entry(2)),int(entry(3)), 

Int(entry(4))) 

mInnod-min(Int(entry(2)),Int(entry(3)), 
int(entrv(4))) 

If (antry(5) .na. 0.) than 

maxnod-maxfmaxnod,intfentryf5}}} 
mlnnod-mln(mInnod,int(antry(5;); 
andl f 

Ibanwd«3*(1+maxnod-mInnod) 

If (Ibanwd .gt. malhbw) then 
Iarror-6 
goto 70 
endi f 

do 65 itcons-2,4 
nodi-int(entry(I toons)) 
startp-itcons+1 
do 65 Index-startp,5 
nod2«int(antry(index)) 

If (nod2 .na. 0) than 

if (nodi .aq. nod2) than 
ierror-7 
goto 70 

a I se 

If (fcoonodfl,nod1 ) .aq. coonodf1,nod2}} .and. 
(coonod(2,nod1) .eq. coonod(2,nod2))) then 
ierror-8 
goto 70 
end! f 
endi f 
endi f 
continue 

if (Ibanwd .gt. maxban) maxban-Ibanwd 
endi f 
endi f 
goto 3000 


( continued ) 
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ELSE 

goto 30 
endif 

70 txtpar(1)®’number of nodes In the model 

txtpar(2)®'number of types of materials In the model 
txtpar(3)*’number of beams In the model 
txtpar(4)®'number of plates In the model 
txtpar(5)«’number of fasteners In the model 
txtpar(6)®’number of loaded nodes In the model 
txtpar(7)®'number of restrained displacements In the model 
txtpar(8)-'node number 
txtpar(9)®’x coordinate of the node 
txtparf10)®'y coordinate of the node 
txtparC11)®'materI a I number 
txtpar(12)®'Young''s modulus of the material 
•’PoIsson’’s ratio of the material 
•'beam number 

•'Index of the first node of the beam 
•'Index of the second node of the beam 
•'beam area 

•'beam moment of inertia 
•'beam material code 

•'distributed load at the first node of the beam 
•’distributed load at the second node of the beam 
•’plate number 

•’index of the first node of the plate 
•’index of the second node of the plate 
txtpar(25)®'Index of the third node of the plate 
txtpar(26)«’ index of the fourth node of the plate 
txtpar(27)«*plate thickness 
txtpar(28)®’plate material code 
txtpar(29)®’fastener number 

txtpar(30)*’Index of the first node of the fastener 
1 index of the second node of the fastener 
’fastener area 
’fastener stiffness 
Ioaded node number 

'applied load at the node along the x direction 


txtparC13j 
txtparC140 
txtpar(15J 
txtpar(16) 
txtpar(17 J 
txtpar(18) 
txtpar(19; 
txtpar(20) 
txtpar(21 ; 
txtpar(22) 
txtpar(23) 
txtpar(24) 


txtpar(31 
txtpar(32) 
txtpar(33) 
txtpar(34)®'I 
■>)«'< 


txtpar(35) 

txtpar(36)®'appIied load at the node along the y direction 
txtpar(37)®'applied moment at the node along the z direction 
txtpar(38)®* node number with a restrained degree of freedom 
txtpar(39)®'restrained degree of freedom of the node 
txtpar(40)®'Imposed displacement at the node 
write (*,80) errmsg(Ierror) 

80 FORMAT (//' ERROR : ’,A50) 
cal I dlskroom (67) 

write (2,80,err*2000) errmsg(I error) 
messge(1)■’ 

+ * 

messge(2)»' 

+ ’ 

messge(3)®’ 

+ 

cal I setstr (240,MESSGE(1)) 
stcons®'Encountered ’ 

call movstr (messae(1),1,1,stcons,1,11) 

IF (I error .eq. 1) THEN 

stcons®* attempting to read * 

ELSE 

stcons®* In * 

endl f 

call setstr (25,stcons) 

call constr (messge(1),stcons) 

call pakstr (messge(l)) 

stcons®' line ’ 

call setstr (6,stcons) 

call constr (messge(1),stcons) 

call pakstr (messge(l)) 

call constr (messge(l).space) 

call wrfstr (float(Iinumb).stcons) 

call constr (messge(1),stcons) 

call pakstr (messge(l)) 

stcons** of file ’ 

call setstr (9,stcons) 

call constr (messge(1).stcons) 

call constr (messge(1),space) 
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cal I setstr (78,InpfiI) 
caI I pakstr (lnpfiI) 
call constr (messge(1),inpfI I) 
period-*. * 

caI I setstr (2,period) 

call constr (messge(1),period) 

call wrltxt (messge) 

IF (ierror .eq. 1) goto 3000 
grafch«char(218) 
cal I setstr (79,1ine) 
call filstr (196,line) 
call movstr (line,1,0,grafch,1,1) 
if (chrerr .ne. 0) then 
grafch-char(25) 

call movstr (Iine,chrerr+1,0,grafch,1,1) 
end! f 

length-lenstr (buffer)+2 
grafch-char(191) 

call movstr (Iine,Iength,0,grafch,1,1) 
length-length+1 
call endstr (length,Iine) 
cal I resstr (Iine) 
write (*,90) Iine 
90 format (1x,A79) 
cal I diskroom (82) 
write (2,90,err-2000) line 
Iength-length-3 
cal I setstr (79,Iine) 
grafch-char(179) 

call movstr (Iine,1,0,grafch,1,1) 
call movstr (Iine,2,0,buffer,1,length) 
length=length+2 

call movstr (Iine,length,0,grafch,1,1) 
length-length+1 
cal I endstr (length,Iine) 
cal I resstr (Iine) 
write (*,90) Iine 
cal I diskroom (82) 
write (2,90,err-2000) line 
grafch-char(192) 
cal I setstr (79,1ine) 
cal I filstr (196,1ine) 
call movstr (line,1,0,grafch,1,1) 
if (chrerr .ne. 0) then 
grafch-char(24) 

call movstr (Iine,chrerr+1,0,grafch,1,1) 
end! f 

I ength-1enstr (buffer)+2 
grafch-char(217) 

caI I movstr (IIne,Iength,0,grafch,1,1) 

length-length+1 

call endstr (Iength,IIne) 

caI I resstr (I ine) 

wr l te (*,90) Iine 

caI I diskroom (82) 

write (2,90,err«2000) line 

call filstr (32,messge(1)) 

if (ierror .eq. 6) then 

stcons-’ The bandwidth for * 

call movstr (messge(1),1,0,stcons,1,18) 

call movstr (messgef1),20,0,Iintyp(idline),1,16) 

call pakstr (messge(l)) 

call constr (messge(1),space) 

call wrfstr (entry(1),stcons) 

call constr (messge(1),stcons) 

stcons-' is • 

cal I setstr (4,stcons) 

call constr (messge(1),stcons) 

call constr (messge(1),space) 

call wrfstr ifloat(Ibanwd),stcons) 

call constr (messge(1),stcons) 

stcons-’ and exceeds the maximum ' 

call setstr (25,stcons) 

call constr (messge(1),stcons) 

stcons-’ allowed bandwidth of ' 







cal 1 

setstr 

cal 1 

constr 

cal 1 

constr 

cal 1 

wrfstr 

ca 1 1 

constr 

cal 1 

constr 

cal 1 

writxt 

goto 

3000 


jfl).stcons) 
j(1).space) 


1 22,stcons) 
messgeM* 

messge(1,_, 

floot(malhbw).stcons) 
messge(1),stcons) 
messge(1).perlod) 
messge) 


endif 
If (lerror .eq. 7) 
stcons-* There 


ca I 
cal 

stcons«*s In 


then 

are Identical 


node’ 


cal 
cal 
cal 
cal 
ca I 
cal 
ca I 
ca I 
ca I 
ca I 
ca I 
cal 
goto 

end I f 

If (lerror 
stcons- 


movstr (messge(1),1,0,stcons.1,25) 
pakstr (messge(l)) 


setstr 
constr 
constr 
setstr 
constr 
resstr 
pakstr 
constr 
wr f str 
constr 
constr 
wrItxt 
3000 


(5,stcons 
(messgefl 
(messge(1 


.stcons) 

_ „ r ,space) 

16,Ilntyo(IdlIne)) 
messge(l),I Intyp(Idline)) 
‘Intypfldline)) 
messgeM )) 
messge(1),space) 
entry(1).stcons) 


(messgeM 
(messge(1 
(messge) 


!: 


stcons) 

period) 


eq. 8) then 


Nodes 


ca I I 
ca I I 
cal I 
cal I 
cal I 


movstr 
pakstr 
constr 
wr fstr 
constr 
stcons-* and 
cal I setstr 
constr 
constr 
wrfstr 
constr 
stcons-* of 
cal I setstr 
constr 
setstr 
constr 
resstr 
pakstr 
constr 
wr fstr 
constr 


,1,0,stcons,1,6) 
.space) 


cal I 
cal I 
ca I I 
ca I I 


messge 
messge 

messge % „ _ r _„ 

float(nod1).stcons) 
messge(1).stcons) 

[5,stcons) 

( messgef1' 

'messge(1, 
floot(nod2).stcons) 
[messge(l).stcons) 


sM) .stcons) 
5(1) .space) 


cal I 
cal I 
ca I I 
ca I I 
ca I I 
cal I 
ca I I 
cal I 


5,stcons) 
messge(l).stcons) 

16.Iintyp(idlIne)) 
messge(l),Ilntyp(Id IIne)) 
Iintyp(idline)) 


Jmessge(1 
[messge 


w. 


space) 


fentry(1).stcons) 
(messge(1).stcons) 
stcons-* have the same coordinat 


caI I setstr 
cal I constr 
stcons-*es. 
caI I setstr 
constr 
wrItxt 
3000 


cal I 
cal I 
goto 
end! f 


(25.stcons) 
(messge(1).stcons) 

f4,stcons) 
(messge(1).stcons) 
(messge) 


if (lerror .eq. 9) then 

stcons-* The * 

cal I movstr fmessgef1),1,0,stcons,1,5) 

call pakstr (messge(l)) 

call constr (messge(1),space) 

call setstr (30,Iinent(idline)) 

cal I constr (messgeM), I inent (Idl ine)) 

call resstr (Ilnent(Idline)) 

call pakstr (messgeM)) 

call constr (messge(1),space) 

call wrfstr (entry(1).stcons) 

call constr (messge(1),stcons) 

stcons-* appear twice. * 

call setstr (15,stcons) 

call constr (messge(1),stcons) 
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call wrItxt (messge) 
goto 3000 
end i f 

stcons** Reading • 

call movstr (messge(l),1,0,stcons,1,8) 

If (Idparm .eq. 1) then 

call movstr (messge(1),10,0,Iintyp(idIine),1,16) 

call pakstr (messge(l)) 

stcons-' I Ines * 

cal I setstr (7,stcons} 

call constr (messge(1),stcons) 

e I se 

call movstr (messge(1),10,0,Iinent(idIine),1,30) 
call pakstr (messge(l)) 
call constr (messge(1).space} 
call wrfstr (entry(1),stcons) 
call constr (messge(1),stcons) 
endlf 

stcons-’ It was expected to find ’ 

cal I setstr(25,stcons) 

call constr(messge(1),stcons) 

If ((Idparm .eq. 1) .and. (idllne .gt. 7)) then 
stcons-’ a ’ 

e I se 

stcons-' the * 

endl f 

call setstr (5,stcons) 
call constr (messge(1 ), stcons) 
call pakstr (messge(l)) 
call constr (messge(1),space) 

Index*Itxtpr(id Iine,Idparm) 

call setstr (49,txtpar(index)) 

cal I constr (messge(l),txtpar(index)) 

call resstr (txtpar(index)) 

call pakstr (messge(l)) 

index-ItyparildlIne,idparm) 

call setstr (14,typpar(Index)) 

cal I constr (messgeM),typpar(index)) 

call resstr (typpar(index)) 

call pakstr (messge(l)) 

stcons-’ between ’ 

call setstr fl0,stcons) 

call constr (messgeM),stcons) 

call wrfstr (boulowfldline,idparm),stcons) 

call constr (messge(1),stcons) 

stcons-’ and ’ 

call setstr (6,stcons) 

call constr (messgefl),stcons) 

call wrfstr (bouhigCidlIne,idparm),stcons) 

call constr (messge(1),stcons) 

stcons-' - as the ’ 

cal I setstr (11,stcons) 

call constr Cmessge(1),stcons) 

call setstr (8,ordInI(Idparm)) 

call constr (messgefl),ordinI(Idparm)) 

call resstr (ordlnICIdparm)) 

call pakstr (messge(l)) 

stcons-’ entry. ’ 

call setstr (8,stcons^ 

call constr (messge(1),stcons) 

call wrltxt (messge) 

goto 3000 

1000 write (*,1010) 

1010 format (//’ ERROR : CANNOT READ INPUT FILE.’/ 

+ ' The program cannot continue.’) 

ierror—1 
goto 3000 

2000 write (*,2010) 

2010 format (//’ ERROR : CANNOT WRITE OUTPUT FILE.’/ 

+ ' The program cannot continue.’) 

Ierror—1 

3000 return 
end 

$PAGE 


( continued ) 
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SUBROUTINE wrltxt (messge) 

C 

C Write text on the screen formatting to avoid breaking words 
C 

IMPLICIT INTEGER (a-z) 

CHARACTER messge*80,I 1ne*79,endwrd*3,space*2 
DIMENSION messge(3) 

Ilne«* 

+ 

cal I setstr (79,1Ine) 
endwrd-* 

call setstr (3,endwrd) 
space-' * 

call setstr (2,space) 
call expstr (messge(l)) 
startp-1 

endtxt-locstr (1,messge(1),endwrd) 

110 Index«startp+79 

IF (ENDTXT .ge. Index) THEN 
spcpos-startp-1 
120 nxtspc-spcpos+1 

Iength-Iocstr (nxtspc.messge(1),space) 

IF (length .It. index) THEN 
spcpos-Iength 
GOTO 120 
end! f 

Iength-spcpos-startp 

cal I movstr (IIne,1,1,messge(1).startp,length) 
call resstr (line) 
write (*,90) IIne 
90 format (1x,A79) 

cal I dlskroom (82) 
write (2,90,err-2000j line 
cal I setstr (79,1ine) 
startp-spcpos+1 
GOTO 110 
end I f 

endtxt-endtxt-1 

call movstr (I Ine,1,1,messge(1),startp.ENDTXT) 

cal I resstr (IIne) 

wr Ite (*,90) IIne 

caI I dlskroom (82) 

write (2,90,err«2000) line 

goto 3000 

2000 write (*,2010) 

2010 format (//* ERROR : CANNOT WRITE OUTPUT FILE.*/ 

+ * The program cannot continue.*) 

ierror—1 
3000 return 
end 

$PAGE 

FUNCTION degree (oppsid,cI osid) 

C 

C Determine angle in degrees with opposite and next side of triangle. 
C 

IF (abs(closid) .gt. 1e-19) THEN 

degree-57.2957795*ATAN(oppsId/cI osid) 

IF (closid .LT. 0.) degree-degree+180. 

IF (degree .gt. 180.) degree-degree-360. 

ELSE 

IF (oppsid .ge. 0.) then 
degree-90. 

e I se 

degree—90. 
end! f 
ENDIF 
RETURN 
END 

$PAGE 

SUBROUTINE datstr(strIng) 

C 

C Write the date in a string. 

C 

IMPLICIT Integer (a-z) 

CHARACTER string*11,blank*2,buffer*10 
call date (day.month.year) 
write (buffer,10) month,day.year 
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10 FORMAT (!2,7\I2.7\I4) 

READ (buffer,20) string 
20 format (a10) 

cal I setstr (11.string) 
asciic«ascstr(4,string) 

if (ascitc .eq. 32) call modstr (string.4,48) 

RETURN 

END 

$PAGE 

SUBROUTINE timstr(string) 

C 

C Write the time-of-day in a string. 

C 

IMPLICIT integer (a-z) 
real realsc 

CHARACTER string*12,bIank*2,buffer*11 
call time (hour.minute,second,sec100) 
reaI sc-fI oat(second)+fI oat(sec100)/100. 
write (buffer,10) hour,minute,reaI sc 
10 FORMAT (12,* s *,12,*:*,f5.2) 

READ (buffer,20) string 
20 format (all) 

caI I setstr (12,string} 
asc1ic«ascstr(4,string) 

if (asclic .ea. 32) call modstr (string,4,48) 
asciic*ascstr(7,strIng) 
if (asdic .eq. 32) then 

call modstr (string,7,48) 
asciic«ascstr(8,string) 

if (asciic .eq. 32) call modstr (string,8,48) 
endi f 
RETURN 
END 

$PAGE 

FUNCTION fltstr (string) 

C 

C Calculate the floating point value of a string. 

C 

CHARACTER buffer*26,strIng*25 
write (buffer,*) string 
READ (buffer,10,ERR-300) intstr 
10 format (bn,125) 

fltstr«float(intstr) 
goto 500 
300 fltstr-0 

READ (buffer,310,ERR-500) fltstr 
310 format (bn,f25.0) 

500 RETURN 
END 

$PAGE 

SUBROUTINE wrfstr (reaI,string) 

C 

C Write a real in a string. 

C 

implidt integer (a-z) 
real real 

CHARACTER string*25,expnnt*5 
if (real .eq. 0.) then 

strlng«'0 • 

call setstr (25,string) 
cal I endstr (2,string) 

e I se 

If ((abs(real) .ge. 1.e11) .or. (abs(real) .It. l.e-5)) then 
write (string,10) real 
10 format (E12.6E2) 

cal I setstr (25,string) 
call pakstr (string) 
expnnt-'E 

call setstr (5,expnnt} 

cal I endstr (2,expnnt) 

l-locstr (1,string.expnnt) 

cal I movstr (expnnt,1,1,string,I,4) 

30 1-1-1 

if (ascstr(I,strIng) .eq. 48) goto 30 
cal I movstr (string,1 + 1,1.expnnt,1,4) 


( continued ) 
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e I se 

write (string,40) real 
40 format (F19.10) 

call setstr (25,string) 
cal I pakstr (string) 
l-lenstr (strlng)+1 
50 1-1-1 

If (ascstr(I,8tring) .eq. 48) goto 50 
if (ascstr(I,strIng) .eq. 46) 1-1-1 
call endstr (1+1,string) 
endif 
endif 
RETURN 
END 


safe2soI.for 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


$LINESIZE: 132 
SPAGESIZE: 61 
SSTORAGE: 2 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c 

c MICROSAFE 

C Structural Analysis by Finite Elements 

C Module : SAFESOLV, 1st Part 

C Version : 2-D 

C 

C COPYRIGHT (C) by MICROSTRESS Corporation - 1985,1986 

C ALL RIGHTS RESERVED 

C 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 
PROGRAM safesolv 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

C c 

c TYPE SPECIFICATION C 

c c 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

INTEGER ppmuqq.ofnfIg.echfIg,serf Ig.ascstr,long I*4,longj*4, 

+ longk*4,long I*4,ddrIve.odrive,prevld,memava*4,numeIe*4 

DOUBLE PRECISION Invqcn,stmtrx,stmqcn,disdof,beamcf,ftcons,pthIck, 
+ eyoung.pratio,diffnc,blngth,bmlcos,bmlsIn,appldf, 

+ ratlo.sttemp,th 

CHARACTER InpfI I*78,outfI I*78,toufiI*78,txtdisp*24,comand*127, 

+ space*2,string*5,datext*11,timtxt*12,intgst*25,dash*1, 

+ prompt*56,diamsg*110,reacIb*8,arrow*1,elipss*4, 

+ bIank*1,IfdrIv*6,Ifpath*64,ifname*9,ifextn*5,fIspec*78, 

+ ofdriv*6,ofpath*64,ofname*9,ofextn*5,toextn*5 

LOGICAL ffound 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

C c 

ARRAY DIMENSIONING C 

c c 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

DIMENSION lnvqcn(2,2),ftconsf9),diffnc(2,4),txtdisp(3),plints(3), 
box la I(600).bshear(2,600),bmomnt(2,600),inp(3).entry(8), 
sttemp(8,2),reacIb(3),youngm(20),poisson(20), 

Ienhbw(l200),nodst3(400),igndof(1200),beamcf(3,3), 
mxndIf(400),nodebm(2,600),bmarea(600),bmlner(600), 
matcbm(600),bmdisl(600),bmdis2(600),pIteth(500), 
matepI(500),nodefs(2,60),fsarea(60),fsstif(60). 


nodepl(4,500) 


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 


COMMON SPECIFICATION 


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

COMMON /global/ numdof,8tmqcn(2,2) 
common /si 2 «bw/ malhbw 

COMMON /plates/ disdof(1203),pIteef(2,4),pIstrs(3,500). 

+ reafor( 3 ,400),pstnor(3,400),pstacc(3,400) 
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COMMON 

common 

common 

COMMON 

common 


/qqqqqq/ 
/filenm/ 
/forces/ 
/dskrom/ 
/coord1/ 


stmtrx(8200) 
inpfiI,out f i I 
appldf(1200) 
serf Ig,odrive 
coonod(2,401) 


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 


c 

c 

c 


USER DEFINED FUNCTIONS 


C 

C 

C 


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

previd(k,I)-M0D(k+l-2,I)+1 
nexti d(k,I)=MOD(k, I )+1 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c c 

C GENERAL INITIALIZATION C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

call time (inithr,initmn,initsc,Iniths) 
caI I datstr (datext) 


C 

C 

C 

C 

C 

C 


call timstr (timtxt) 

Show copyright notice on the screen. 

cal I logpsI 
InitialIze variabIes. 


serf Ig-0 
maxban=6 
8 tmqcn(1,1)«0. 
stmqcnM ,2}=0. 
stmqcnf2,1)«0. 
stmqcn(2,2)«0. 
space-’ * 

cal I setstr (2,space) 

toextn-*.OUT ’ 

call setstr (5,toextn) 

eIlpss-*... * 

cal I setstr (4,elipss} 

call defdrv (0,ddrive) 


C 

C 

C 


Determine number of stiffness matrix elements which will fit in RAM. 


name Ie-memava(stmtrx(1))/4 
if (numele . gt. 65535) numele-65535 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c c 

C READ THE COMMAND TAIL C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

1 error-ppmuqq 


Iength-ascstr 
if (length .ne. 
caI I setstr 
caI I endstr 
caI I movstr 
caI I upcstr 
string-’ I- 
caI I setstr 


S 0 ,0,comand) 
1 ,comand)+2 


2 ) then 
'127,comand) 

Iength,comand) 

'comand,1,0,space,1,1) 
’comand) 


(4,«trIng) 

locatn-locstr (1,comand,string)+3 
If (locatn .ne. 3) then 

nxtloc-locstr (Iocatn,comand,space) 
If (nxtloc .eq. 0) nxtloc-length 
numchr-nxtloc-locatn 
inpfII-’ 


cal I setstr f78,inpfiI) 

caI I movstr (inpfI I,1,0,comand,locatn.numchr) 
cal I resstr (Inpf11) 
ifnflg-1 
endi f 

call modstr (string,2,79) 
locatn-locstr (1.comand,string)+3 
if (locatn .ne. 3) then 

nxtloc-locstr (Iocatn,comand,spaced 
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If (nxtloc .eq. 0) nxtloc«length 
numchr-nxtloc-locatn 
outfII-' 

+ * 

cal I setstr (78,outf1I) 

call movstr (outfI I,1,0,comand,locatn,numchr) 
cal I resstr (outfI1 ) 
ofnfIg-1 
endi f 

string-* E 

cal I setstr (3,string) 
locatn-locstr (1,comand,string) 

If (locatn .ne. 0) echflg-1 
call modstr (strIng,2,83) 
locatn-locstr (1,comand,strIng) 
if (locatn .ne. 0) scrflg=1 
endi f 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

SET INPUT AND OUTPUT FILES 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

65 if (ifnflg .eq. 0) then 
WRITE (*,70) 

70 FORMAT (' Input data file name [.INP]? ’\) 

READ (*,*(A)*) inpfil 

e I se 

WRITE (*,72) inpfil 

72 FORMAT (' Input data file name [.INP]: \a78) 
endi f 

fIspec-inpfi I 

call parsfn (fI spec,ddrIve,lfdr Iv,idr Ive,Ifpath,ifname,ifextn) 

Inpf1l-fI spec 

if (Ienstr(Ifextn) .eq. 0) then 
Ifextn-'.INP ' 
caI I setstr (5,ifextn) 
call constr (InpfiI,ifextn) 
endi f 

cal I resstr (inpf11) 

inquire (FILE-inpfiI,EXIST«ffound) 

If (ffound) then 

OPEN (1,FILE-inpfII) 

e I se 

cal I setstr (78,InpfiI) 

caI I pakstr (InpfI I) 

length-lenstr (inpfiI) 

cal I expstr (inpfiI ) 

cal I resstr (inpfiI) 

call wrfstr (float(length),intgst) 

length-lenstr (intgst) 

prompt-'('' ERROR : File '"',a ,'cannot be found. Try agai 

+n.'') ’ 

call setstr (56,prompt) 
call movstr (prompt,21,0,Intgst,1,Iength) 
write (*,prompt) inpfil 
ifnfIg=0 
goto 65 
ENDIF 

74 toufil-InpfiI 

cal I setstr (78,touf11) 

locatn-locstr (1,toufI I,Ifextn) 

call movstr (toufiI,locatn,1,toextn,1,4) 

length-lenstr (toufil) 

caI I expstr (toufI I) 

caI I resstr (touf11 ) 

call wrfstr (float(length),Intgst) 

length-lenstr (intgst) 

prompt-'(*' Output data file name [”,a '*,a78 ) 

+ • 

call setstr (56,prompt) 

call movstr (prompt,30,0,intgst,1,length) 

if (ofnflg .eq. 0) then 

call modstr (prompt,35,63) 

string='\ ' 

cal I setstr (5,string) 

call movstr (prompt,38,0,string,1,4) 
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ca I I resstr (prompt) 

WRITE (*,prompt) toufil 
READ (*.’(A)’) outfI I 

e I se 

cal I resstr (prompt) 

WRITE (*,prompt) toufiI,outfiI 
end! f 

fIspec«outfi I 

call parsfn (fI spec,idrive-1,ofdr1v,odr!ve,ofpath,ofname,ofextn) 
outfil*fI spec 

IF (Ienstr(ofdr!v) .le. 2) then 
cal I setstr (78,outf!I) 

( 1 .< . 


cal I endstr (1,outf11) 
If ( I enstr(ofdriv) .eq 
(Ienstr(ofpath) .eq 
(I enstr(ofname) .eq 
' Ienstr(ofextn) .eq 


constr 
constr 
constr 
constr 


0 ) 

8 

0 ) 


(outfiI,ofdriv] 
outfiI,ofpath) 
outfiI,ofname) 
outf!I,ofextn) 


of dr i v* 
of path* 
of name= 
of extns 


Ifdriv 
ifpath 
\fname 
toextn 


if 
If 
If 

cal I 
cal I 
cal I 
ca I I 
endi f 

cal I resstr (outfI I) 
caI I opnfII (Ierror) 
if (lerror ,ne. 0) then 
ofnfIg=0 
goto 74 
end! f 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c c 

C START THE OUTPUT FILE C 


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

caI I diskroom (0) 


C 

c 

c 


Header title 


caI I diskroom (331) 

WRITE (2,80,err«2000) datext,timtxt,inpfiI,outfiI 

80 FORMAT ('MICROSAFE - STRUCTURAL ANALYSIS BY FINITE EL*. 

+ 'EMENTS\4x,’Version: SAFESOLV (2-D)',2x,’ReI. 1.0’,3x,a10 f 1x,a8// 
+/* Input data file : ’,A/* Output data file : ',A/) 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c c 

C START READING THE INPUT FILE C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

diamsg=*Reading model data from file 

+ 


cal 1 

setstr ( 

[110,diamsg) 

cal 1 

setstr < 

[78,InpfI 1) 

cal 1 

movstr 1 

^diamsg,30,0,inpfi1,1,77) 

ca 1 1 

resstr 1 

[inpfi1) 

ca 1 1 

pakstr ( 

fdiamsg) 

ca 1 1 

constr 1 

[diamsg,elIpss) 

ca 1 1 

expstr < 

f diamsg) 

ca 1 1 

resstr 1 

[dIamsg) 

cal 1 

resstr 1 

[ofdr Iv) 


it ^orariv .eq. ’CON: j sen ig—i 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c c 

C READ AND PROCESS THE MODEL SIZE LINES C 


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c 


Size header 

If (echflg .eq. 1) then 

If (scrflg .eq. 1) then 
WRITE (*,85) 

85 FORMAT (/’ SIZE OF THE STRUCTURE’/) 

e I se 

If (scrflg .eq. 0) write (*,87) diamsg 
87 format (/IX,A/’ Slze...’\) 

end! f 
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ca I I dlskroom (30) 

WRITE (2,85,err«2000) 

• I se 

write (*,87) dlomsg 
end i f 

Number of nodes and degrees of freedom 

CALL verlf y(1.entry,I error.maxban.youngm) 

IF (lerror .NE. 0) GOTO 994 
nnodes«entry(1) 

If (echflg .eq. 1) then 

If (serf Ig .eq. 1) WRITE (*,90) nnodes 
90 FORMAT (* Number of nodes :*,I4) 

caI I diskroom (48) 

WRITE (2,90,err-2000) nnodes 
endlf 

DO 92 loop-1.nnodes 
DO 92 Indx-1,3 
reaforfindx,loop)«0. 
pstnorflndx,loop)»0. 

92 pstacc(indx,loop)=0. 
numdof«3*nnodes 
DO 94 loop-1.numdof 
94 appIdf(Ioop)«0. 

maIhbw-numeIe/numdof-2 
If (malhbw .gt. numdof) maIhbw-numdof 
longj-numdof*(maIhbw+2) 
do 96 long 1-1,long] 

96 stmtrx(longl)-0. 

Number of types of material 

CALL verIfy(2,entry,lerror.maxban.youngm) 

IF (lerror .NE. 0) GOTO 994 
nmater-entry(1) 

If (echflg .eq. 1) then 

If (scrflg .eq. 1) WRITE (*,98) nmater 
98 FORMAT (* Number of materials :*,I4) 

cal I dlskroom (48) 

WRITE (2,98,err-2000) nmater 
endlf 

Number of beams 

CALL verlfy(3,entry,lerror.maxban.youngm) 

IF (lerror .NE. 0) GOTO 994 
nbeams-entry(1) 
if (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*,100) nbeams 
100 FORMAT (' Number of beams :',I4) 

call dIskroom (48) 

WRITE (2,100,err-2000) nbeams 
endlf 

Number of plates 

CALL ver1fy(4,entry,I error.maxban.youngm) 

IF (lerror .NE. 0) GOTO 994 
nplate-entry(l) 

If (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*.105) nplate 
105 FORMAT (’ Number of plates :*,I4) 

caI I dlskroom (48) 

WRITE (2,105,err«2000) nplate 
endlf 

DO 107 loop-1.nplate 
DO 107 indx-1,3 
107 plstr8(Indx,loop)-0. 

Number of fasteners 

CALL verIfy(5,entry,ierror.maxban.youngm) 

IF (lerror .NE. 0) GOTO 994 
nfastn«entry(1) 

If (echflg .eq. 1) then 
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if (scrflg .eq. 1) WRITE (*,110) nfastn 
110 FORMAT (’ Number of fasteners :’,I4) 

call diskroom (48) 

WRITE (2,110, er r*=2000) nfastn 
endi f 


C 

C Number of loaded nodes 
C 

CALL verify(6,entry,ierror,maxban,youngm) 

IF (Ierror .NE. 0) GOTO 994 
n lnods=entry(1) 
if (echflg .eq. 1) then 

If (scrflg .eq. 1) WRITE (*,115) nlnods 
115 FORMAT (’ Number of loaded nodes :’,I4) 

cal I dlskroom (48) 

WRITE (2,115,err=2000) nlnods 
end i f 


C 

C Number of restrained degrees of freedom 
C 

CALL verIfy(7,entry,Ierror,maxban,youngm) 

IF (Ierror .NE. 0) GOTO 994 
nresdf«entry(1) 

If (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*,120) nresdf 
120 FORMAT (’ Number of restrained degrees of freedom :’,I4) 
caI I diskroom (48) 

WRITE (2,120,err*2000) nresdf 
endlf 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c c 

C READ AND PROCESS THE NODE COORDINATES LINES C 

C C 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c 

C Coordinates of the nodes 
C 

if (echflg .eq. 1) then 

If (scrflg .eq. 1) then 
WRITE (*,125) 

125 FORMAT (//* NODE COORDINATES '//' Node Coordinate X 

+ ’Coordinate Y'/) 

e I se 

if (scrflg .eq. 0) write (*,130) 

130 format (’Nodes ...’\) 

endif 

caI I diskroom (68) 

WRITE (2,125,err*2000) 

e I se 


write (*,130) 
endif 

call chkdup (0,ierror) 

DO 160 loop»1,nnodes 

CALL verify(8,entry,ierror,maxban,youngm) 

IF (ierror .NE. 0) GOTO 994 
i-entry(l) 

coonodM , i )*entry(2) 
coonod(2,i)«entry(3) 
if (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*,150) i,entry(2),entry(3) 

150 FORMAT (I5,3X,F12.5.3X,F12.5) 
call diskroom (37) 

WRITE (2,150,err®2000) I,entry(2),entry(3) 
endi f 

160 CONTINUE 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c c 

C READ AND PROCESS THE MATERIAL PROPERTIES LINES C 

C C 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

c 

C Material properties 
C 

If (nmater .gt. 0) then 

If (echflg .eq. 1) then 

If (scrflg .eq. 1) then 
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175 


180 


190 


endlf 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c READ AND PROCESS THE BEAM LINES 

c 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 


write (*,170) 

FORMAT (//’ MATERIAL PROPERTIES’// 1 Code Young’, 
e|8 ^ IH’.'s modulus’,’ Poisson’,1H’,’s ratio’/) 

It (serfIg .eq. 0) write (*,175) 
format (’Mater I a Is...’\) 
endlf 

cal I dlskroom (78) 

WRITE (2,170,err«2000) 

e I se 

write (*,175) 
endlf 

call chkdup (0,lerror) 

DO 190 Ioop«1,nmater 

CALL verlfy(9,entry,lerror,maxban,youngm) 

IF (lerror ,NE. 0) GOTO 994 

I-entry(l) 

youngm(I)*entry(2) 

poIsson(I)«entry(3) 

if (echflg .eq. 1) then 

1 .. 

call dIskroom (39) 

WRITE (2.180.err-2000) I,entry(2),entry(3) 
endlf J 

CONTINUE 


Beams 
IF 


200 


+ 

+ 


Beam I j 
M. Inertia’, 
Distributed Loads 


7 ) 


205 


(nbeams .gt. 0) then 
If (echflg .eq. 1) then 

If (scrflg .eq. 1) then 
write (*,200) 

FORMAT (//’ BEAM DATA’//’ 

’Length Area 

’ Material 

e I se 

If (scrflg .eq. 0) write (*,205) 
format (’Beams...’\) 
endlf 

cal I dlskroom (114) 

WRITE (2,200,err=2000) 

else 

write (*,205) 
endlf 

cal I chkdup (0,ierror) 

DO 220,loop=1,nbeams 

CALL verify(10,entry,ierror,maxban,youngm) 

IF (ierror .NE. 0) GOTO 994 
i«entry(1) 
n1=entry(2) 
n2=*entry(3) 
mat«entry(6) 
bmarea( i )*=entry(4) 
matcbm(I)*mat 
eyoung=youngm(mat) 
if ((entryf4) .ne. 
nodebm(1,i)«n1 
nodebmf2,i)=n2 
bminer(i)=entry(5) 
bmdlsl(I)=entry(7) 
bmdis2fI)=entry(8) 
mxndlf(nl)*MAX(n1,n2,mxndif(nl)) 
mxndif(n2)«MAX(n1,n2,mxndif(n2)) 
endlf 

diffncfl, 2 ^*coonodf 1 ,n 2 )-coonod( 1 ,n 1 ) 
diffnc( 2 , 2 )«coonod( 2 ,n 2 )-coonod( 2 ,nl) 

ff n ?iJhf l5 R !^ if 1) C tll;n ) * diffnC 1,2)+diffnC(2,2) * diffnc(2 ’ 2)) 

if (scrflg'.eq. 1) WRITE (*.210) I,n1,n2.b1ngth,entry(4), 


0 .) .and. (eyoung .ne. 0.)) then 
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+ entry(5),mat,entry(7),entry(8) 

210 FORMAT (I5,2I6.F12.3,F10.4,F14.5,5X,I3,5X,2F12.3) 

cal I diskroom (92) 

WRITE (2,210,err*2000) I,n1,n2,bI noth,entry(4),entry(5), 
+ mat,entry(7),entry(8) 

endif 

If ((entry(4) .ne. 0.) .and. (eyoung .ne. 0.)) then 
bmlcos*diffnc(1,2)/blngth 
bmlsln=dlffnc(2,2j/bIngth 
IF (entry(5) .NE. 0.) THEN 
nodst3(n1)*1 
nodst3(n2)*1 
ENDIF 
I3*3*n1 
12*13-1 
11*12-1 
J3«3*n2 
J2*J3-1 
J1-J2-1 

IF ((entry(7) .NE. 0.) .OR. (entry(8) .NE. 0.)) THEN 
ftcons(1)»entry(7)*blngth/6 
ftcons(2)»entry(8)*bIngth/6 
ftcons(3)=ftcons(1)*bIngth/30 
ftcons(4)*ftcons(2)*bIngth/30 

appIdf(I1)*appIdf f11)-bmIsIn*(2*ftcons(1)+ftcons(2)) 
appldf (I2)*appldf c I2Wbml cos*(2*f tcons(1 )+ftcons(2)) 
appIdf(I3)*appIdf(I3)+8*ftcons(3)+7*ftcons(4) 
appIdf fj1)*appIdf(j1)-bmIsIn*(ftcons(1}+2*ftcons(2)) 
appIdf(j2)*appIdf(j2)+bmIcos*(ftcons(1)+2*ftcons(2)) 
appldf(J3)*appIdf(J3)-7*ftcons(3)-8*ftcons(4) 

ENDIF 

ftconsfl}»2*eyouna*entry(5)/bIngth 
ftcons(2)*entry(4)*eyoung/bIngth 
ftcons(3}*bmlsin/blngth 
ftcons(4;*bmlcos/bIngth 

ftcons(5)*6*ftcons(1 )*ftcons(3)*ftcons(3)+ 

+ bmlcos*bmIcos*ftcons(2) 

ftcons(6)*6*ftcon8(1)*ftcons(3)*ftcons(4)- 
+ bmlcos*bmlsin*ftcons(2) 

ftcons(7)*6*ftcons(1)*ftcons(4)*ftcons(4)+ 

+ bmlsln*bmlsin*ftcons(2) 

ftcons(8}*-3*ftcons(1}*ftcons(3} 
ftcons(9)*-3*ftcons(1)*ftcons(4) 

CALL assemble (l 1,11,ftcons(5),-ftcons(6},ftconsf8)) 

CALL assemble (II,j1,-ftcons(5),ftcons(6),ftcons(8); 

CALL assemble (12,12,ftcons(7},-ftcons(9},0.) 

CALL assemble (12,jl,ftcons(6),-ftcons(7),-ftcons(9)) 
CALL assemble (13,13,ftcons(1)*2,0.,0.) 

CALL assemble (13,j1,-ftcons(8),ftcons(9),ftcons(1)) 

CALL assemble (j1,j1,ftcons(5),-ftcons(6),-ftcons(8)) 
CALL assemble (J2,j2,ftcons(7),ftcons(9),0.) 

CALL assemble (j3,j3,ftcons(1)*2,0.,0.) 

e I se 


If (scrfig .ge. 0) write (*,215) I 
215 FORMAT (/* WARNING : The beam*,14, 


+ • has been disconnected from the model.*/) 

caI I dlskroom (69) 

WRITE (2,215,err«2000) I 

If ((echflg .eq. 0) .or. (scrfig .eq. 0)) wrlte(*,217) 
217 format (* *\) 

endl f 

220 CONTINUE 
endif 


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c 

READ AND PROCESS THE PLATE LINES C 

C 

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 


Plates 

IF (nplate .gt. 0) then 

If (echflg .eq. 1) then 

If (scrfig .eq. 1) then 
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240 


245 


250 


260 


270 


280 


write (*,240) 

FORMAT (//• PLATE DATA*//' Plate I 

* L Thickness Material*/) 

e I se 

if (scrflg .eq. 0) write (*,245) 
format (’Plates...*\) 
endl f 

cal I diskroom (78) 

WRITE (2,240,err-2000) 

e I se 

write (*,245) 
endl f 

call chkdup (0,lerror) 

DO 360,loop«1,npI ate 

CALL verIfy(11,entry,lerror,maxban,youngm) 

IF (lerror .NE. 0) GOTO 994 
I«entry(1) 
n1«entry(2 
n2»entry(3 
n3=entry(4 
n4«entry(5, 
pthIck*entry(6) 
mat«entry(7) 

If (echflg .eq. 1) then 

If (scrflg .eq. 1) WRITE 
FORMAT (15,416,F11.5.5X.I3) 
call diskroom (50) 

WRITE (2,250.err«2000) I,N1,n2,N3,N4,pthick,mat 
endl f 

*entry(6) 

=mat 

eyoung*youngm(mat) 

If ((pthlck .ne. 0.) .and. (eyoung .ne. 0.)) then 
pratio«poisson(mat) 
lndx«MAX(n1,n2,n3,n4) 


K*. 


(*,250) I,N1,n2,N3,N4,pthick,mat 


pltethfl)- 
matcp1(1)* 


,lndx) 

,Indx) 

,Indx) 

=MAX(mxndIf(N4),Indx) 
■coonod(1,N1J 
■coonod(2,N1' 

■coonod(1,N2 j 
l-coonod(2,N2) 


)»coonod( 


>-coonod| 

[1.N3) 

)»coonod| 

k2.Ni ) 

>-coonodl 

:2.N3) 

)«coonod(1,N4)-coonodl 

;i.N3) 

j-coonodl 

2.N4 

)-coonod| 

;2.N3) 

)=coonodl 

Ji.ni; 

)-coonod| 

(1.N4) 

T7 

o 

c 

o 

o 

o 

N 

;2 ,ni; 

)-coonod| 

(2.N4) 


mxndlf(n1)«MAX(mxndlf 
mxndlf (n2)*MAX(mxndlf 
mxndlf(n3)«MAX(mxndlf 
IF (n4 .GT. 0) mxndlf 
diffnc(1 ,2)«coonod(1 ,N2 
diffnc(2,2)*coonod(2,N2 
dIf fnc(1,3)«coonod(1,N3 
diffnc(2,3)*coonod(2,N3 
IF (N4 .EQ. 0) THEN 
dlffnc(1,1] 
dIf fnc(2, 

ELSE 

diffnc( 
dlffnc( 
dlffnc( 
dlffnc(2,1] 

ENDIF 
INDX-1 

IF (dlffnc(1,2)*diffnc(2,3) .GT. diffnc(2,2)*diffnc(1,3)) 
INDX-INDX+4 
IF (N4 .EQ. 0) THEN 

IF (INDX .EQ. 1) THEN 
n-n2 
n2»n3 
n3*n 
ENDIF 

ELSE 

.GT. 

)) INDX=INDX+2 
.GT. 

INDX=INDX+1 

GOTO (260,270,280,300,310,280,300,320) indx 
n«n2 
n2«n4 
n4*n 

GOTO 320 
n«n2 
n2«n3 
n3=n 

GOTO 320 
WRITE (*.290) I 



IF (diffnc(" 

1.31 

l*d i f f nc| 

[2A) 

+ 

diffnc(J 

2.3! 

l*di f fncl 

il.4) 


IF (diffncT 

1.4 

!*di f fncl 

;2.n 

+ 

diffnc(J 

2.4) 

l*diffncl 

1.1 
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290 FORMAT (* ERROR : ILLEGAL NODE DECLARATION FOR *, 

+ •PLATE*,14,*.*) 

call diskroom (50) 

WRITE (2,290,err«2000) i 
goto 994 

300 n-n2 

n2»n3 
n3«n4 
n4*n 

GOTO 320 

310 n»n3 

n3-n4 
n4=n 

320 CONTINUE 

ENDIF 

nodep1(1,1)-N1 
nodep1(2,1)=N2 
nodep1(3,1)=N3 
nodepl(4,I)«N4 
IF (N4 .EQ. 0) THEN 

CALL trlasemb (N1,N2,N3,pthIck,eyoung,pratio) 

ELSE 

coonod(1, nnodes+1)-(coonod(1,N1)+coonod(1,N2)+ 

+ coonodM,N3)+coonod(1,N4))/4 

coonod(2,nnodes+1)«(coonod(2,N1)+coonod(2,N2)+ 

+ coonod(2,N3)+coonod(2,N4))/4 

CALL trlasemb (N1,N2,nnodes+1.pthick,eyoung,pratio) 

CALL trlasemb (N2,N3,nnodes+1,pthick,eyoung,pratio) 

CALL trlasemb (N3,N4,nnodes+1,pthlck,eyoung,pratio) 

CALL trlasemb (N4,N1,nnodes+1,pthick,eyoung,pratio) 
ftcons(1)«stmqcn(1,1)*stmqcn(2,2)- 
+ stmqcn(1,2)*stmqcn(2,1) 

InvqcnM,1)-stmqcn(2,2)/ftcons(1) 
lnvqcn(2,2J*stmqcn(1,1)/ftcons(1) 
lnvqcn(1,2)—stmqcn(1,2)/ftcons(1) 
lnvqcn(2,1)«invqcn(1,2) 

DO 330 NI-1,4 
DO 330 MI-1,2 
n-(nodepI(NI,l)-1)*3+MI 
DO 330 NJ-NI,4 
IF (NJ .EQ. NI) THEN 
MK-MI 

ELSE 

MK-1 

ENDIF 

DO 330 m J «MK,2 
J-(nodepI(NJ,1)-1)*3+MJ 
k-minfn,J) 
l-max(n,J)-k+1 
longk-(malhbw+2)*(k-1)+l 
do 332 m-1,2 

longl-fmalhbw+2)*(n-1)+malhbw+m 
ftcon8(2)«0. 
do 331 mm-1,2 

longj-(maIhbw+2)*(1-1)+maIhbw+mm 

331 ftcons(2)«ftcons(2)+stmtrx(longj)*lnvqcn(m,mm) 

332 stmtrx(longk)«stmtrx(longk)-ftcons(2)*stmtrx(longi) 

330 CONTINUE 

DO 350 NI-1,2 
DO 340 M-1,4 
DO 340 MI-1,2 

longl-TmaIhbw+2)*((nodepI(M,i)-1)+3+MI)+ni-2 
stmtrx(longi)«0. 

340 CONTINUE 

DO 345 MI-1,2 

345 «tmqcn(ml,ni)-0. 

350 CONTINUE 

ENDIF 

e I se 

if (scrflg .ge. 0) write (*,355) 1 
355 FORMAT (/* WARNING : The pi ate*,14, 

+ * has been disconnected from the model.’/) 

caI I dlskroom (70) 

WRITE (2,355,err-2000) I 

If ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217) 

( continued ) 
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end! f 

360 CONTINUE 
endi f 



READ AND PROCESS THE FASTENER LINES 


Fasteners 

IF (nfastn .gt. 0) then 

if (echflg .eq. 1) then 

If (scrflg .eq. 1) then 
WRITE (*,380) 

380 FORMAT (//’ FASTENER DATA7/ 

+ * Fastener I J Area StiffnessV) 

e I se 

if (scrflg .eq. 0) write (*,385) 

385 format ('Fasteners...’\) 

endi f 

call diskroom (70) 

WRITE (2,380,err-2000) 

e I se 

write (*,385) 
endi f 

call chkdup (0,lerror) 

DO 400 loop-1.nfastn 

CALL verify(12,entry,ierror,maxban,youngm) 

IF (lerror .NE. 0) GOTO 994 

i-entry(1) 

n1-entry(2} 

n2«entry(3) 

if (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*,390) I,n1,n2,entry(4),entry(5) 
390 FORMAT (I5,2I6.F12.6,F11.0) 

cal I diskroom (42) 

WRITE (2,390,err-2000) i,nl,n2,entry(4),entry(5) 
end! f 

fsstif(I)-entry(5) 

If (entry(5) .ne. 0.) then 
ftconsf1)»entry(5) 
nodefs(1,1}-n1 
nodefs(2,i)«n2 
fsarea(I)-entry(4) 

I1»3*n1-2 

12 *11+1 

J1«3*n2-2 

J2-J1+1 

mxndif(n1)-MAX(n1,n2.mxndif(nl)) 
mxndlf(n2)«MAX(n1,n2,mxndif(n2)) 

CALL assemble (II,II,ftcons(1),0.,0.) 

CALL assemble (II,jl,-ftcons(1),0.,0.) 

CALL assemble (12,12,ftcons(1),0.,0.) 

CALL assemble (12,j2, — ftcons(1),0.,0.) 

CALL assemble (j1,j1,ftcons(1),0.,0.) 

CALL assemble (J2,J2,ftconsQI),0.,0.) 

e I se 

if (scrflg .ge. 0) write (*,395) i 
395 FORMAT (/' WARNING : The fastener',14, 

+ ' has been disconnected from the model.’/) 

call diskroom (73) 

WRITE (2,395,err-2000) I 

if ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217) 
end! f 

400 CONTINUE 
end i f 

Fix unstlffened degrees of freedom 

DO 470 loop-1,nnodes 
N1-3*Ioop-2 

IF (nodst3(loop) .ne. 1) then 

IF (mxndif(loop) .EQ. 0) THEN 

If (scrflg .ge. 0) write (*,465) loop 
465 FORMAT (/' WARNING : The node',14, 
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+ • is not connected to any element In the model.'/) 

call diskroom (77) 

WRITE (2,465,err-2000) loop 

if ((echflg .eq. 0) .or. (scrflg .eq. 0)) write(*,217) 

igndof(nl)-l 

disdof(nl)-0. 

igndof(nl+1)«1 

disdof(n1+1)=0. 

ENDIF 


igndof(N1+2)=1 
disdof(N1+2)=0. 
endi f 


470 CONTINUE 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
C c 

C READ AND PROCESS THE NODE LOADS LINES C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c 

C Node loads 
C 

IF (nlnods .gt. 0) then 

if (echflg .eq. 1) then 

if (scrflg .eq. 1) then 
WRITE (*,410) 

410 FORMAT (//' NODE LOADS'//' Node PX\ 

+ ’ PY MZ'/) 

e I se 


If (scrflg .eq. 0) write (*,415) 
415 format ('Loads...'\) 

end I f 

cal I diskroom (75) 

WRITE (2,410,err-2000) 

e I se 


write (*,415) 
endi f 

cal I chkdup (0,terror) 

DO 450 loop-1,nlnods 

CALL ver!fy(13,entry,I error.maxban,youngm) 

IF (terror .NE. 0) GOTO 994 
I«entry(1) 

If (echflg .eq. 1) then 

if (scrflg .eq. 1) WRITE (*,440) I,entry(2),entry(3), 
+ entry(4) 

440 FORMAT (15,1X.3F14.2) 

cal I diskroom (50) 

WRITE (2,440,err-2000) I.entry(2),entry(3),entry(4) 
endi f 


N1-3*I-3 
DO 445 j-1,3 

appIdf(N1+J)-appIdf(N1+J)+entry(j + 1) 
445 reafor(j,I)«reafor(J,i)-entry(j+1) 

450 CONTINUE 

endi f 


Initialize displacements 

DO 460 Ioop«1,numdof 
460 disdof(loop)«appldf(loop) 

Determine last non-zero element In each row 

i-0 

JHB-6 

DO 480 loop-1,nnodes 
J-3*(mxndlf(loop)-loop+1) 

IF (J .LT. JHB) THEN 
J-JHB 

ELSE 

JHB-J 

ENDIF 

DO 480 K-1,3 
i-t+1 

Ienhbw(I)«min(J,numdof-!+1) 

j-M 

480 CONTINUE 


(continued) 
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cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
C c 

C READ AND PROCESS THE NODE RESTRAINTS LINES C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c 

C Fixed displacements 
C 

IF (nresdf .gt. 0) then 

If (echflg ,eq. 1) then 

if (scrfig .eq. 1) then 
WRITE (*.490) 

490 FORMAT (//' MOVEMENT RESTRAINTS'//' Node 

+ 'Type of restraint Displacement*/) 

e I se 

if (scrfig .eq. 0) write (*,495) 

495 format ('Restraints...*\) 

end! f 

caI I diskroom (90) 

WRITE (2.490,err*2000) 

e I se 

write (*,495) 
endi f 

cal I chkdup (0,ierror) 
txtdispf 1 }*’Trans I at Ion along X axis' 
txtdisp(2)**Translation along Y axis' 
txtdisp(3)** Rotation about Z axis ' 

DO 510 loop*1.nresdf 

CALL verify(14,entry,ierror.maxban.youngm) 

IF (ierror .NE. 0) GOTO 994 
i*entry(1) 
indxfd=entry(2) 

If (echflg .eq. 1) then 

If (scrfig .eq. 1) WRITE (*,500) I,txtdisp(1ndxfd), 

+ entry(3) 

500 FORMAT (I5.8X,A24.F15.5) 

call dIskroom (54) 

WRITE (2,500,err*2000) 1,txtdisp(indxfd),entry(3) 
end i f 

N1*3*(i-1)+lndxfd 
disdof(N1)-entry(3) 

IF (entry(3) .EQ. 0.) THEN 
igndof(N1)*2 

ELSE 

longI*(maIhbw+2)*(n1-1)+1 
stmtrxflong!)*1D30 
disdof(N1)*stmtrx(longi)*entry(3) 
igndof(Nl)«-2 
ENDIF 

510 CONTINUE 
endi f 
CLOSE (1) 

if ((echflg .eq. 0) .or. (scrfig .eq. 0)) WRITE (*,512) 

512 format ('End') 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 
c c 

C SOLVE THE SYSTEM [K]{u}-{F{ AND REPORT THE RESULTS IN THE SCREEN C 
C AND THE OUTPUT FILE C 

C C 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

write (*,522) numdof.maxban 

522 format (/' Solving the system [K]{u}«{FJ...'/' Number of degrees’, 
♦ ' of freedom :',15,' Bandwidth :•i4// 

+ ' PASS 1 : FORWARD ELIMINATION’) 

11«*1+numdof/80 
J1«numdof/i1-2 
k 1 **78— j 1 
dash-*-' 
arrow*'' 

write (*,524) arrow,(dash,1*1,j1).arrow,(bIank,j*1,k1) 

524 format (1x,80a1) 

C 

C Calculate displacements 
C 

longI*-malhbw-1 
DO 535 1*1,numdof 
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525 


529 


530 


535 


536 


540 


550 

555 


If (nextld(I,M) .eq. 1) call pacer 
longi*longi+maIhbw+2 
IF (Igndof(I) .le. 0) then 

IF (ABSfstmtrx(longi)) .LT. .000001) THEN 
M«(i-1)/3+1 
j1*i-3*(i1-1) 

WRITE (*.525) M.J1 

FORMAT (//* ERROR : THE STIFFNESS MATRIX APPEARS TO BE*, 

SINGULAR.•/* The elements connected to node ',13 
do not contribute any stiffness in the free*/ 
f * degree of freedom *,11 # *.•/) 

cal I diskroom (162) 

WRITE (2,525.err*2000) 11, jl 
goto 994 
end I f 

DO 530 J*1,Ienhbw(I)-1 

l-i+J 

IF ((igndof(l) .le. 0) .and. (stmtrx(Iongi+j) .ne. 0.)) then 
RATIO=stmtrx(longl+j)/stmtrx(longi) 

Iongl«(maIhbw+2)*j+Iongi-1 
DO 529 k-j+1,lenhbw(I) 

I ongI * IongI+1 

IF (igndof(l) .le. 0) stmtrx(IongI)*stmtrx(IongI)- 
h ratio*stmtrx(longi-1+k) 

CONTINUE ' 

stmtrxflongl+j)»ratIo 
disdof(I)«disdof(I)-RATIO*disdof(I) 
end! f 
CONTINUE 

disdof(i)=disdof(I)/stmtrx(longi) 

ENDIF 
CONTINUE 
write (*,536) 

format (/* PASS 2 : BACKWARDS SUBSTITUTION*) 
write (*,524) arrow,(dash,1-1.j1).arrow.(bIank,j-1,k1) 
if (nextid(numdof,II) .eq. 1) call pacer 
DO 550 l-numdof-1,1,-1 
if (next!d(1,11) .eq. 1) call pacer 
I ongj«(maIhbw+2)*(1-1)+1 
IF (igndof(i) .le. 0) then 
DO 540 K-1,lenhbw(i)-1 

disdof(i)-dlsdof(I)-stmtrx(longJ+k)*disdof(i+k) 
endif 
CONTINUE 
write (*,555) 

format (/* The system has been succesfully solved.*) 


cal 1 

setstr 

cal 1 

setstr 

cal 1 

movstr 

ca 1 1 

resst r 

ca 1 1 

pakstr 

cal 1 

constr 

ca 1 1 

expstr 

cal 1 

resstr 


Print displacements 

if (serf Ig .eq. 0) then 

d!amsg-*WritIng results to file 
+ * 

! 110 ,diamsg) 

78,outfI I) 

dlamsg,25.1,outfiI,1,77) 
out fiI) 
diamsg) 

diamsg.elIpss) 

S diamsg) 
diamsg) 
write (*,680) diamsg 

680 format (/IX,A/* DispIacements...*\) 
endif 

if (scrflg .eq. 1) THEN 
WRITE (*,685) 

685 FORMAT (//* NODE DISPLACEMENTS’// 

+ * Node U V Omega*/) 

endl f 

cal I diskroom (76) 

WRITE (2.685,err-2000) 

DO 700 J«1.nnodes 
If (mxndlf(J) .ne. 0) then 

690 ^? r (!!.ix!if&!) ITt ( '’ 6M) 1-1.3) 

cal I diskroom (44) 

WRITE (2.690.err-2000) J,(disdof(3*(J-1)+l), 1 - 1 , 3 ) 


[continued) 
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endi f 

700 CONTINUE 


MZ1 


Beam corner force* 

IF (nbeams .gt. 0) then 

If (scrflg .eq. 1) then 
WRITE (*.710) 

710 FORMAT (//’ BEAM CORNER FORCES 1 // 

+ * Beam I J FX1 FY1 

+ • FX2 FY2 MZ2’/) 

else , . 

if (scrflg .eq. 0) write (*,205) 
endi f 

cal I diskroom (125) 

WRITE (2,710,err-2000) 

DO 740 i-1,nbeams 
mat-matcbm(i) 
eyoung-youngm(mat) 

if ((eyoung .ne. 0.) .and. (bmarea(I) .ne. 0.)) then 
n1-nodebm(1, 1) 
n2«nodebm(2,i) 

diffnc(1,2)-coonod(1,n2)-coonod(1,n1) 
diffnc( 2 , 2 )«coonod( 2 ,n 2 )-coonod( 2 ,n 1 ) 
bIngth-DSQRT(diffnc(1,2)*diffnc(1,2)+ 

+ diffncf2.2)*diffnc(2.2)) 

bmlcos-dlffncM,2)/blngth 
bmlsin-diffnc(2,2)/bIngth 
I1«3*n1-2 

J1-3*n2-2 , v 

ftcons(1)*disdof(J1)-dlsdof(II) 
ftcons(2)«disdof(J1+1)-disdof(11+1) 

ftcons(3)*3*(bmIsin*ftcons(1)-bmlcos*ftcons(2))/bIngth 
f tcons(4)-(bmdis1(I)+bmdi s2( i))*blngth/2. 

ftcons(5)-2*eyoung*bminer(i)/bIngth 

f tcons(6)=eyoung*bmarea(i)*(bmlcos*f tcons(1)+ 

+ bmlsin*ftcons(2))/bIngth 

beamcf(3.1)«ftcons(5)*(ftcons(3)+2*disdof(I1+2)+ 

+ disdof(J 1 + 2 ))-(8.*ftcons(4)-bmdis2(i)* 

+ blngth/2.)*blngth/90. 

beamcf(3,2)-ftcons(5)*(2*disdof(J1+2)+disdof(I1+2)+ 

+ f tcons(3n+(8.*f tcons(4)-bmdisi(i )* 

+ blngth/2.)*bIngth/90. 

ftcons(7)-(ftcons(4)+bmdis1(I)*blnath/2.)/3.- 
+ (beamcf(3,1)+beamcf(3,2))/bIngth 

ftcons(8)=ftcons(7)-ftcons(4} 

beamcf(1,1)—bmlcos*ftcons(6)+bmIsin*ftcons(7) 
beamcf(1,2)-bmlcos*ftcons(6)-bmlsin*ftcons(8) 
beamcf(2.1)=-bmlsin*ftcons(6)-bmlcos*ftcons(7) 
beamcf( 2 , 2 )»bmlsin*ftcons(6)+bmIcos*ftcons(8) 

DO 720 J-1,2 

DO 720 k-1,3 , , Wl .v 

reafor(k,nodebm(j,1))»reafor(k,nodebm(j,i))+beamcf(k,j) 

720 CONTINUE 

baxia I(I)-ftcons(6) 

bshear(1, i)«ftcons(7) 

bshear(2,i)=ftcons(8) 

bmomnt (1, i )—beamcf (3,1) 

bmomnt(2,I)-beamcf(3,2) 

if (scrflg .eq. 1) WRITE (*,730) I,n1,n2, 

+ (beamcf(k,1),k-1,3),(beamcf(k,2),k-1.3) 

730 FORMAT (15,216,IX,6F12.0) 

cal I diskroom (92) . . 

WRITE (2,730,err-2000) i,n1,n2,(beamcf(k,1),k-1,3), 

+ (beamcf(k,2),k-1,3) 

endi f 

740 CONTINUE 


C 

c 

c 


Beam loads and stresses 

if (scrflg .eq. 1) WRITE (*,750) 

750 FORMAT (//* BEAM LOADS AND STRESSES*// 

+ * Beam I J PAX SAX 

+ »SH1 SH2 BM1 BM2*/) 

call diskroom (130) 

WRITE (2.750,err-2000) 
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DO 760 1*1,nbeams 
mat«matcbm(I) 

If ((youngm(mat) .ne. 0.) .and. (bmarea(l) .ne. 0.)) then 
ftcons(1)«baxial(I)/bmarea(l) 

If (serfIg .«q. WRITE (*.730) I.(nodebm(k,i),k-1,2). 

+' box Ial(I),ftcons(1),(bsh«ar(k,l),k«1,2),(bmomnt(k,I),k«1,2) 

cal I diskroom (92) 

WRITE (2,730,err-2000) I,(nodebm(k,I),k«1,2).baxiaI(I). 

+ ftcons(l),(bshear(k,I),k«1,2),(bmomnt(k,i),k»1,2) 

end I f 

760 continue 
endl f 


Plate corner forces 


IF (nplate .gt. 0) then 

If (scrflg .eq. 1) then 
WRITE (*,770) 

770 FORMAT (//’ PLATE CORNER FORCES*// 

♦ * Plate I J K L FX1 FY1 

+ 'FX2 FY2 FX3 FY3 FX4 FY4*/) 

e I se 

If (scrflg .eq. 0) write (*,245) 
end I f 

cal I diskroom (138) 

WRITE (2.770,err-2000) 

DO 850 LPL-1,nplate 
TH-pIteth(LPL) 
mat-matcpl(Ipl) 
eyoung*youngm(mat) 
pratio-polsson(mat) 

If ((th .ne. 0.) .and. (eyoung .ne. 0.)) then 
DO 780 1-1,2 
DO 780 J-1,4 

780 pIteef(I,J)-0. 

IF (nodepI(4,LPL) .EQ. 0) THEN 

CALL trlloads (1,2,3,th,eyoung,pratlo,Ipl,nodepl) 

ELSE 


+ 

+ 

+ 

+ 


790 


800 

+ 

+ 

+ 

+ 

+ 

+ 

+ 

+ 


coonod(1,nnodes+1)«(coonod(1,nodepI(1,LPL))+ 

coonod(1,nodepI(2,LPL))+coonod(1.nodepI(3,LPL))+ 
coonod(1,nodepl(4,LPL)))/4 
coonod(2,nnodes+1)«(coonod(2,nodepI(1,LPL))+ 

coonod(2,nodepI(2,LPL))+coonod(2,nodepl(3,LPL))+ 
coonod(2,nodepI(4,LPL)))/4 
ftcons(7^«0 
ftcons f8)»0 
ftcons(9)«0 
DO 790 1-1,8 
DO 790 J-1,2 
sttemp(l,j)«0. 
lnp(3)-nnodes+1 
DO 810 1-1,4 
J-nextId(I,4) 

Inp(1)-nodepl(I,LPL) 
lnp(2)-nodepl(J.LPL; 

DO 800 N1-1,2 
DO 800 N2-1,3 

dlffnc(N1,N2)»coonod(N1,lnp(N2))- 

coonod(N1,inp(prevld(N2,3))) 
ftcons(1)-diffnc(2,3)*dlffnc(1,2)- 
dlffnc(1,3)*d!ffnc(2,2) 
ftcons(2)-1/(ftcons(1)*(1+pratIo)) 
ftcons(3)-ftcons(2)*(dIffnc(1,3)*dlffnc(1,2)+ 
dlffnc(2,3)*dlffnc(2,2)) 
ftcons(4)-ftcons(2)*(d!ffnc(2,3)*dlffnc(1,2)- 
dlffncf1,3)*diffnc(2,2)) 
ftcons(5)-ftcons(2)*(dIffnc(1,2)*dlffnc(1,2)+ 
dlffnc(2,2)*dlffnc(2,2)) 
ftcons(6)-1/(ftcons(1)*(1-prat Io)) 
sttemp(2*I-1,1)-sttemp(2*I-1,1)+ftcons(3)+ 

ftcons(6)*d!ffnc(2.2)*dlffnc(2,3) 
sttemp(2*l-1,2)«sttempf2*1-1,2)+ftcons(4)- 

ftcons(6)*dlffnc(2,3)*dlffnc(1,2) 
sttemp(2*l,1)-sttemp(2*1,1)-ftcons(4)- 

ftcons(6)*dIffnc(2,2)*d!ffnc(l,3) 


(continued) 
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+ 

+ 


820 


sttemp(2*I,2)»sttemp(2*I,2)+ftcons(3)+ 

ftcons(6)*dlffnc(1,3)*diffnc(1,2) 
sttemp(2* J-1,1 )-sttemp(2*J-1,1 )-ftcons(3)-ftcons(5)+ 
ftcons(6)*diffnc(2,2)*diffnc(2,1) 
sttemp(2* J-1,2)«sttemp(2*J-1,2)-ftcons(4)- 

ftcons(6)*dlffnc(2,1)*diffnc(1,2) 
sttemp(2*J,1)«sttemp(2*J,1)+ftcons(4;- 

ftcons(6)*dlffnc(2,2)*dlffnc(1,1} 
sttemp(2*J,2)»sttempi 2*J,2)-ftcons(3)-ftcons(5) + 
ftcons(6)*diffnc(1,1)*diffnc(1,2) 



ftcons(7)-ftcons! 

;7) 

l+f tcons ( 

+ 

ftcons! 

6 

l*di f fnc( 


ftcons(8)-ftcons! 

[8] 

>- 

+ 

ftcons! 

[8] 

l*dlf fnc( 


<0 

c 

0 

0 

-♦-* 

1 

cn 

CO 

c 

0 

0 

«•-» 


l+f tcons( 

+ 

ftconsl 

(6)*diffnc( 


810 CONTINUE 

ftconsfl}»0 
ftcons(2)-0 
DO 820 1-1,4 
f tcon8(1 )«f tcons(1 )- 

+ sttempi 2*1-1,1)*disdof(3*nodepl(I,LPL)-2)- 

+ sttemp(2*I,1)*dlsdof(3*nodepI (I,LPL)-1) 

f tcons (2)-ft consi¬ 
st temp(2*I-1,2)*di sdof (3*nodep I (I,LPL)-2)- 
sttemp(2*I,2)*dIsdof(3*nodepl(I,LPL)-1) 

CONTINUE 

ftcons(3)-ftcons(7)*ftcons(9)-ftcons(8)*ftcons(8) 
dlsdof(numdof+1)-(ftcons(1)*ftcons(9)- 
+ ftcons(8)*ftcons(2))/ftcons(3) 

disdof(numdof+2)«(ftcons(2)*ftcons(7)- 
+ ftcons(8)*ftcons(1))/ftcons(3) 

I— nnodes-1 
CALL tr Moods 
CALL tr Moods 
CALL tr Moods 
CALL tr Moods 
DO 830 1-1,3 
830 pIstrs(I,LPL)«pIstrs(I,LPL)/4 

ENDIF 

If (serf Ig .eq. 1) WRITE (*,840) LPL,(nodepI(k,LPL),k«1,4) 
+ •((pI tec f(I,J),1-1,2),J-1,4) 

840 FORMAT (15,416,IX,8F9.0) 

cal I diskroom (104) 

WRITE (2,840,err-2000) LPL,(nodepI(k,LPL).k-1,4), 

+ ((pltecf(i,J),i-1.2).J»1,4) 

end! f 

850 CONTINUE 


( 1 , 2 , I,th,eyoung,pratio,Ipl,nodepI ) 
(2,3,1,th.eyoung.pratio,Ipl,nodepI) 
f3,4,i,th,eyoung,pratio,Ipl,nodepI ) 
(4,1,1,th,eyoung,pratio,Ipl,nodepI) 


Plate load-intensities and stresses 


860 

+ 

+ 

+ 


870 

+ 

+ 


+ 


+ 

+ 


880 


if (scrflg .eq. 1) WRITE (*,860) 

FORMAT (//* PLATE LOAD INTENSITIES AND STRESSES*// 

* Plate I J K L PIX PIY TXY*, 

* SX SY TAU SMAX SMIN TMAX * , 

* Angle*/) 

caI I diskroom (172) 

WRITE (2,860,err-2000) 

DO 890 LPL-1,nplate 
mat-matepI(IpI) 

if ((piteth(Ipl) *ne. 0.) .and. (youngm(mat) .ne. 0.)) then 
DO 870 1-1,3 

pIints(I)«pIstrs(I,LPL)*pIteth(LPL) 
ftcons(3)-SQRT(pIstrs(3,LPL)*pIstrs(3,LPL)+ 

.25*(pIstr$(2,LPL)-pIstrs(1,LPL))*(pIstrs(2,LPL)- 
pIstrs(1,LPL))) 

f tcons(5V.5*(pIstrs(1,LPL)+pIstrs(2,LPL)) 
ftcons(1;«ftcons(5)+ftcons(3) 
ftconsf2)»ftcons(5)-ftcons(3) 
ftcons(4)-degree(2*pIstrs(3,LPL), 

pIstrs(2,LPL)-pI strsfl,LPL))/2. 
if (scrflg .eq. 1) WRITE (*,880) LPL,(nodepl(k,LPL),k-1,4) 
,(plints(k),k-1,3),(pistrs(k.LPL),k-1,3) 
, (ftcons(k),k«1,4) 

FORMAT (15,416,IX,10F9.0) 
cal I diskroom (122) 
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890 


c 

c 

c 


WRITE (2,880,err-2000) LPL,(nodepI(k,LPL),k«1,4), 

(piints(k),k«1,3),(plstrs(k,LPL),k-1,3),(ftcons(k),k-1,4) 
end I f 
CONTINUE 


Plate stresses at node points 


900 


if (serf Ig .eq. 1) WRITE (*,900) 

FORMAT (//• PLATE STRESSES AT NODE POINTS*// 


Node Coordinate X 
• TAU SMAX 

cal I diskroom (151) 
WRITE (2,900,err-2000) 
DO 930 1-1.nnodes 
k-0 

DO 910 J-1,3 
IF (pstnor(J,I) .GT. 0 


Coordinate Y 
SMIN TMAX 


SX 
Ang I e 


/) 


SY 


r - , -_.) THEN 

ftcons(j)«pstacc(J,I)/pstnor(J,I) 


■ 1 


910 


ELSE 

k 

ENDIF 
CONTINUE 
if (k .ne. 


1 ) then 


ftcons(6)-SQRT(ftcons(3)*ftcons(3)+ 

25*(ftcons(2)-ftcons(1))*(ftcons(2)-ftcons( 1 ))) 


ftcons(8) 
ftcons(4 
ftcons 


5*(ftcons(lj+ftcons(2)) 

(4) -f tcons(8)+f tcons(6) 

(5) -ftcons(8)-ftcons(6; 


920 


930 


C 

C 

C 


--:cons(8)-ftcons(6; 

ftcons(7)«degree(sngI(2*ftcons(3)), 

sngI(ftcons(2)-ftcons(1)))/2. 
if (scrflg .eq. 1) WRITE (*,920) I,coonod(1,I),coonod(2,I) 
v ,(ftcons(k).k—1,7) 

FORMAT (I5,3X,F12.5,3X,F12.5,7F10.0) 
caI I diskroom (107) 

WRITE (2,920,err-2000) I,coonod(1,I),coonod(2,I), 
h (f tcons(k) ,k—1,7) 

endif 
CONTINUE 
endif 


Fastener forces and stresses 


IF 


940 


(nfastn .gt. 0) then 
if (scrflg .eq. 1) then 
WRITE (*,940) 

FORMAT (//* FASTENER FORCES AND STRESSES*// 
' Fastener I J FX FY 

•Angle Stress*/) 

e I se 

if (scrflg .eq. 0) write (*,385) 
endif 

cal I diskroom (113) 

WRITE (2,940,err-2000) 

DO 960 LFS-1,nfastn 
if (fsstif(lfs) .ne. 0.) then 
nl-nodefs(I.LFS) 
fs(2,l 


n2-nodefs( 
I1—3*n1—2 
J1-3*n2-2 


• LFS) 


ftconsi 
ftconsi 
ftconsi 


tif(lfs)*(disdof(I1)-disdof(J1)) 
f sst I f ( I f f ' > •• ■ . 


*f ss 


- x .fs)*(disdof(11 + 1)-disdof(J1 + 1)) 

■SQRT(ftcons(1)*ftcons(1)+ftcons(2)*ftcons(2)) 


--\ w / \ ' \ ■ / ' \ ' /ti kvwnaytyi'i ivvi 

ftcons(4Wdegreefsngl(ftcons(2)),sngI(ftcons(1))) 


ftcons(5)«ftcons(3)/fsarea(Ifs) 


950 


if (scrflg .eq. 1)WRITE (*,950) LFS,n1,n2, 

. (ftcons(k),k-1,5) 

FORMAT (15,216,IX,5F10.0) 
cal I diskroom (70) 


WRITE 

reafor 


2,950,err-2000) LFS,n1,n2,(ftcons(k),k—1,5) 


reafor(l,n2 
reafor(2,nl 


1 ,n1)-reafor(1,n1)+ftcons(1 


960 


reafor(2,n2, 
endl f 
CONTINUE 
endif 


■reafor(1,n2)-ftcons h 
■reafor f 2,nl Uf tcons(2 
■reafor(2,n2)-ftcons(2j 


( continued ) 
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c 


Node internal forces and reactions 


reaclb(l)** • 

reaclb(2)«* • 

reacIb(3)»*ReactIon * 

If (serf Ig .eq. 1) then 
WRITE (*.970) 

970 FORMAT (//* NODE INTERNAL FORCES AND REACTIONS*// 

♦ * Node Coordinate X Coordinate Y FX* 

+ ’ FY M2 7) 

else 

If (scrflg .eq. 0) write (*.972) 

972 format (’React Ions ...*\) 
end! f 

cal I diskroom (142) 

WRITE (2,970.err«2000) 

DO 990 I«1.nnodes 

if (scrflg .«q. 1) WRITE (*.980) I,coonod(1,1),coonod(2.1), 

__ .. (reafor(J.I).reacIb(1+abs(Igndof((1-1)*3+J))),j>»1.3) 

980 FORMAT (I5.3X.F12.5.3X.F12.5,3(F12.0,1x.a8.1x)) 1 ' 

caI I diskroom (103) 

WRITE (2.980.«rr-2000) I,coonod(1,I),coonod(2,I), 

990 + CONTINUE ( r * af « r (J.0.reaclb(1+abs(igndof((i-1)*3+J))).J-1.3) 
if (scrflg .eq. 0) write (*.512) 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c c 

c REPORT THE EXECUTION TIME C 

c c 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c 

C Report the execution time 

c 

994 cpusec«0. 

call time (lasthr,lastmn.Iostsc,losths) 

If (lasthr .It. Inlthr) cpusec-86400. 

cpusec-cpusec+3600.*(lasthr-lnlthr)+60.*(lostmn-inltmn)+lastsc- 
+ lnitsc+.01*(la*ths-iniths) 

„ Ae l f ( 8crf ‘,9 -9«- 0) write (*.995) cpusec 

995 format (//* Execution time : \f8.2.* seconds.’) 

If (terror .ns. -1) then 

call dIskroom (43) 
write (2,995,err-2000) cpusec 
end! f 

write (*.999) 

999 format (* *) 

STOP 

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 

c REPORT UNSPECIFIED I/O ERRORS DETECTED C 

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 

1000 write (*,1010) 

1010 format (//* ERROR : CANNOT READ INPUT FILE.*/ 

+ * The program cannot continue.*) 

goto 994 ' 

2000 wrIte (*,2010) 

2010 format (//* ERROR : CANNOT WRITE OUTPUT FILE.’/ 

+ * The program cannot continue.’) 

Ierror*-1 
goto 994 
END 


expstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE EXPSTR - SUBROUTINE TO EXPAND A STRING TO ITS SIZE 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
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COMMENT * 

EXPSTR Is a routine designed to be called from FORTRAN as a subroutine 
to expand a string from its actual length to its size by filling the 
string with blanks. 

Mode of use: 

call EXPSTR (string) 

where 

string « name of the string (variable of type CHARACTER) to be 
expanded. 


♦ 

SUBTTL FORMAL DECLARATIONS 
PAGE 


csexps 

SEGMENT 

•CODE’ 


ASSUME 

CS:csexps 

SUBTTL 

EXPSTR - 

EXECUTABLE CODE 

PAGE 



PUBLIC 

expstr 


expstr 

PROC FAR 


PUSH 

BP 


MOV 

BP.SP 


PUSH 

ds 


LDS 

BX,DWORD PTR [BP+6] 


mov 

ah,32 

; Scan 

for either end-of-string mark. 

scanend: 



mov 

a1.[bx] 


cmp 

al ,0 


jz 

exit 


cmp 

al ,6 


Jz 

fI1Iblanks 


Inc 

bx 


jmp 

scanend 

; Fill 

with blanks between logical and 

f i 1 Iblanks: 



MOV 

[BX],ah 


Inc 

bx 


mov 

al ,[bx] 


cmp 

al ,0 


jnz 

f11Iblanks 

; Exit 



exit: 




POP 

ds 


MOV 

SP.BP 


POP 

BP 


RET 

4 

expstr 

ENDP 


csexps 

ENDS 


END 




punch.inp 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


This file demonstrates the mixture of text (notes) and Input data allowed 
in the Microsafe Program Series. The data for the program is contained 
on the lines that contain a slash character. All lines without a slash 
and any characters following the slash are ignored by the program. 

15 / # of nodes 
1 / # of materials 

4 / # of beams 
8 / f of plates 
0 / # of fasteners 


( continued ) 
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I / # of loaded nodes 

II / # of ImDOsed res! 


1 

0.0 

10.0 / 

2 

0.0 

0.0 / 

3 

0.0 

-10.0 / 

4 

10.0 

10.0 / 

5 

10.0 

0.0 / 

6 

10.0 

-10.0 / 

7 

20.0 

10.0 / 

8 

20.0 

0.0 / 

9 

20.0 

-10.0 / 

10 

30.0 

10.0 / 

11 

30.0 

0.0 / 

12 

30.0 

-10.0 / 

13 

40.0 

10.0 / 

14 

40.0 

0.0 / 

15 

40.0 

-10.0 / 

1 

10.3E6 0.33 / 

1 

2 5 0. 

5 0.1 1 

2 

5 8 0. 

5 0.1 1 

3 

8 11 e 

1.5 0.1 1 

4 

11 14 

0.5 0.1 

1 

2 5 

4 1 0. 

2 

5 8 

7 4 0. 

3 

8 11 

10 7 0.i 

4 

11 14 

13 10 0.i 

5 

3 6 

5 2 0J 

6 

6 9 

8 5 0.1 

7 

9 12 

11 8 0.1 

8 

12 15 

14 11 0.1 


-# Young * s-moduI us PoIsson•s-ratlo 


0.0 0.0 / 


-# Q1 Q2 


1 / 

2 10000. 0.0 0.0 / node f load-x load- 
rest ra I ned-freedon-# 


1 / plate-# nodel node2 node3 node4 thickness material-# 

1 / 

1 / 

1 / 


1 

1 

0.0 

/ node-# 

3 

1 

0.0 

/ 

4 

1 

0.0 

/ 

6 

1 

0.0 

/ 

7 

1 

0.0 

/ 

9 

1 

0.0 

/ 

10 

1 

0.0 

/ 

12 

1 

0.0 

/ 

13 

1 

0.0 

/ 

14 

2 

0.0 

/ never i 

15 

1 

0.0 

/ 


•y moment 
Imposed-deflection 


1 -> restrain x-dlrection 


2 -> 
3 -> 


restrain 

restrain 


y-dIrectIon 
rotatIon 


lug.Inp 

Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


File: LUG.INP is the Idealization of a lug 
with a bolt in the center and bolted to a 
strongback at each end of the flange 
Load angle is 0 deg. 


247 

1 

24 

222 

0 

11 

20 

169 

188 

187 

186 

185 

184 

183 

182 

168 

144 

145 

146 

147 

148 


/ NUMBER OF''NODES 
/ NUMBER OF MATERIALS 

/ NUMBER OF BEAMS 

/ NUMBER OF PLATES 

/ NUMBER OF FASTENERS 

/ NUMBER OF LOADED NODES 

/ NUMBER OF RESTRAINED NODES 


0.0000 

0.0000 

-0.1294 

-0.2500 

-0.3535 

-0.4330 

-0.4829 

-0.5000 

-0.4829 

-0.4330 

-0.3535 

-0.2500 

-0.1294 

0.0000 


1.3000 

1.8000 

1.7829 

1.7330 

1.6535 

1.5500 

1.4294 

1.3000 

1.1706 

1.0500 

0.9464 

0.8670 

0.8171 

0.8000 


/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

•, 

/ 


NODAL DEFINITION 
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149 

0.1294 

0.8171 

150 

0.2499 

0.8670 

151 

0.3535 

0.9464 

152 

0.4330 

1.0500 

170 

0.4829 

1.1706 

194 

0.5000 

1.3000 

193 

0.4829 

1.4294 

192 

0.4330 

1.5499 

191 

0.3535 

1.6535 

190 

0.2500 

1.7330 

189 

0.1294 

1.7829 

209 

0.0000 

1.9000 

208 

- 0.1552 

1.8795 

207 

- 0.3000 

1.8196 

206 

- 0.4242 

1.7242 

205 

- 0.5196 

1.6000 

204 

- 0.5795 

1.4552 

181 

- 0.6000 

1.3000 

167 

- 0.5795 

1.1448 

142 

- 0.5196 

1.0000 

143 

- 0.4242 

0.8757 

121 

- 0.3000 

0.7804 

122 

- 0.1552 

0.7205 

123 

0.0000 

0.7000 

124 

0.1552 

0.7205 

125 

0.2999 

0.7804 

153 

0.4242 

0.8757 

154 

0.5196 

1.0000 

171 

0.5795 

1.1448 

195 

0.6000 

1.3000 

214 

0.5795 

1.4552 

213 

0.5196 

1.5999 

212 

0.4242 

1.7242 

211 

0.3000 

1.8196 

210 

0.1552 

1.8795 

226 

0.0000 

2.0000 

225 

- 0.1811 

1.9761 

224 

- 0.3500 

1.9062 

223 

- 0.4949 

1.7949 

222 

- 0.6062 

1.6500 

203 

- 0.6761 

1.4811 

180 

- 0.7000 

1.3000 

166 

- 0.6761 

1.1189 

141 

- 0.6062 

0.9500 

120 

- 0.4949 

0.8051 

119 

- 0.3500 

0.6938 

101 

- 0.1811 

0.6239 

102 

0.0000 

0.6000 

103 

0.1811 

0.6239 

126 

0.3499 

0.6938 

127 

0.4949 

0.8051 

155 

0.6062 

0.9499 

172 

0.6761 

1.1189 

196 

0.7000 

1.3000 

215 

0.6761 

1.4811 

230 

0.6062 

1.6499 

229 

0.4949 

1.7949 

228 

0.3500 

1.9062 

227 

0.1811 

1.9761 

238 

0.0000 

2.1000 

237 

- 0.2070 

2.0727 

236 

- 0.4000 

1.9928 

235 

- 0.5656 

1.8656 

221 

- 0.6928 

1.7000 

202 

- 0.7727 

1.5070 

179 

- 0.8000 

1.3000 

165 

- 0.7727 

1.0930 

140 

- 0.6928 

0.9001 

118 

- 0.5656 

0.7344 

100 

- 0.4000 

0.6072 

80 

- 0.2070 

0.5273 

81 

0.0000 

0.5000 

82 

0.2070 

0.5273 

104 

0.3999 

0.6072 

128 

0.5656 

0.7344 


/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

* 

* 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

* 

/ 

/ 

* 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

* 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

* 

* 

* 

/ 

/ 

/ 


I continued) 
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156 

0.6928 

173 

0.7727 

197 

0.8000 

216 

0.7727 

231 

0.6928 

241 

0.5656 

240 

0.4000 

239 

0.2070 

245 

0.0000 

244 

- 0.2329 

243 

- 0.4500 

234 

- 0.6363 

220 

- 0.8000 

219 

- 0.9400 

200 

- 1.0900 

201 

- 1.0000 

178 

- 1.0000 

164 

- 1.0000 

139 

- 0.8000 

138 

- 1.0000 

117 

- 0.8000 

99 

- 0.6000 

79 

- 0.4000 

83 

0.4000 

105 

0.6000 

129 

0.8000 

158 

1.0000 

157 

0.8000 

174 

1.0000 

198 

1.0000 

217 

1.0000 

218 

1.0900 

233 

0.9400 

232 

0.8000 

242 

0.6363 

247 

0.4500 

246 

0.2329 

177 

- 1.2400 

162 

- 1.4000 

163 

- 1.2000 

137 

- 1.2000 

116 

- 1.0000 

98 

- 0.8000 

78 

- 0.6000 

56 

- 0.4000 

57 

- 0.2000 

58 

0.0000 

59 

0.2000 

60 

0.4000 

84 

0.6000 

106 

0.8000 

130 

1.0000 

159 

1.2000 

175 

1.2000 

176 

1.4000 

199 

1.2400 

135 

- 1.5450 

112 

- 1.6950 

113 

- 1.6000 

136 

- 1.4000 

114 

- 1.4000 

95 

- 1.4000 

115 

- 1.2000 

96 

- 1.2000 

97 

- 1.0000 

76 

- 1.0000 

77 

- 0.8000 

54 

- 0.8000 

55 

- 0.6000 

32 

- 0.6000 

33 

- 0.4000 

34 

- 0.2000 

35 

0.0000 

36 

0.2000 

37 

0.4000 

61 

0.6000 


0.9000 / 
1.0930 / 

1.3000 / 

1.5070 / 

1.6999 / 
1.8656 / 
1.9928 / 

2.0727 / 
2.2000 / 
2.1693 / 
2.0794 / 

1.9363 / 

1.7650 / 

1.6250 / 

1.4600 / 

1.4600 / 

1.3000 / 

1.1400 / 

0.9800 / 

0.9800 / 

0.8200 / 
0.6350 / 
0.5000 / 

0.5000 / 

0.6350 / 

0.8200 / 
0.9800 / 

0.9800 / 

1.1400 / 

1.3000 / 

1.4600 / 

1.4600 / 

1.6250 / 

1.7650 / 
1.9363 / 
2.0794 / 

2.1690 / 

1.3000 / 

1.1400 / 

1.1400 / 

0.9800 / 

0.8200 / 
0.6600 / 
0.5000 / 

0.3400 / 

0.3400 / 

0.3400 / 

0.3400 / 

0.3400 / 

0.5000 / 

0.6600 / 
0.8200 / 
0.9800 / 

1.1400 / 

1.1400 / 

1.3000 / 

0.9800 / 

0.8200 / 
0.8200 / 
0.9800 / 

0.8200 / 
0.6600 / 
0.8200 / 
0.6600 / 
0.6600 / 
0.5000 / 

0.5000 / 

0.3400 / 

0.3400 / 

0.1700 / 

0.1700 / 

0.1700 / 

0.1700 / 

0.1700 / 

0.1700 / 

0.3400 / 
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62 

0.8000 

0.3400 

85 

0.8000 

0.5000 

86 

1.0000 

0.5000 

107 

1.0000 

0.6600 

108 

1.2000 

0.6600 

131 

1.2000 

0.8200 

132 

1.4000 

0.8200 

133 

1.6000 

0.8200 

134 

1.6950 

0.8200 

160 

1.4000 

0.9800 

161 

1.5450 

0.9800 

93 

- 1.8450 

0.6600 

94 

- 1.6000 

0.6600 

71 

- 2.0000 

0.5000 

72 

- 1.8000 

0.5000 

73 

- 1.6000 

0.5000 

74 

- 1.4000 

0.5000 

75 

- 1.2000 

0.5000 

50 

- 1.6000 

0.3400 

51 

- 1.4000 

0.3400 

52 

- 1.2000 

0.3400 

53 

- 1.0000 

0.3400 

29 

- 1.2000 

0.1700 

30 

- 1.0000 

0.1700 

31 

- 0.8000 

0.1700 

8 

- 0.8000 

0.0000 

9 

- 0.6000 

0.0000 

10 

- 0.4000 

0.0000 

11 

- 0.2000 

0.0000 

12 

0.0000 

0.0000 

13 

0.2000 

0.0000 

14 

0.4000 

0.0000 

15 

0.6000 

0.0000 

16 

0.8000 

0.0000 

38 

0.6000 

0.1700 

39 

0.8000 

0.1700 

63 

1.0000 

0.3400 

64 

1.2000 

0.3400 

65 

1.4000 

0.3400 

66 

1.6000 

0.3400 

87 

1.2000 

0.5000 

88 

1.4000 

0.5000 

89 

1.6000 

0.5000 

90 

1.8000 

0.5000 

91 

2.0000 

0.5000 

109 

1.4000 

0.6600 

110 

1.6000 

0.6600 

111 

1.8450 

0.6600 

48 

- 2.0000 

0.3400 

49 

- 1.8000 

0.3400 

25 

- 2.0000 

0.1700 

26 

- 1.8000 

0.1700 

27 

- 1.6000 

0.1700 

28 

- 1.4000 

0.1700 

40 

1.0000 

0.1700 

41 

1.2000 

0.1700 

42 

1.4000 

0.1700 

43 

1.6000 

0.1700 

44 

1.8000 

0.1700 

45 

2.0000 

0.1700 

67 

1.8000 

0.3400 

68 

2.0000 

0.3400 

2 

- 2.0000 

0.0000 

3 

- 1.8000 

0.0000 

4 

- 1.6000 

0.0000 

5 

- 1.4000 

0.0000 

6 

- 1.2000 

0.0000 

7 

- 1.0000 

0.0000 

17 

1.0000 

0.0000 

18 

1.2000 

0.0000 

19 

1.4000 

0.0000 

20 

1.6000 

0.0000 

21 

1.8000 

0.0000 

22 

2.0000 

0.0000 

70 

- 2.2000 

0.5000 


/ 

/ 

/ 

/ 

/ 

/ 

* 

/ 

/ 

/ 

/ 

* 

* 

/ 

/ 

* 

/ 

/ 

* 

* 

/ 

/ 

* 

* 

* 

/ 

/ 

/ 

/ 

* 

/ 

/ 

/ 

/ 

/ 

/ 

* 

/ 

/ 

/ 

/ 

* 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

/ 

* 


(continual) 
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120 

97 

98 

117 

121 

71 

72 

93 

122 

72 

73 

94 

123 

73 

74 

95 

124 

74 

75 

96 

125 

75 

76 

97 

126 

76 

77 

98 

127 

77 

78 

99 

128 

78 

79 

100 

129 

198 

199 

218 

130 

174 

175 

199 

131 

175 

176 

199 

132 

158 

159 

175 

133 

159 

160 

176 

134 

160 

161 

176 

135 

129 

130 

158 

136 

130 

131 

159 

137 

131 

132 

160 

138 

132 

133 

161 

139 

133 

134 

161 

140 

106 

107 

130 

141 

107 

108 

131 

142 

108 

109 

132 

143 

109 

110 

133 

144 

110 

111 

134 

145 

83 

84 

105 

146 

84 

85 

106 

147 

85 

86 

107 

148 

86 

87 

108 

149 

87 

88 

109 

150 

88 

89 

110 

151 

89 

90 

111 

152 

90 

91 

111 

153 

47 

48 

71 

154 

48 

49 

72 

155 

49 

50 

73 

156 

50 

51 

74 

157 

51 

52 

75 

158 

52 

53 

76 

159 

53 

54 

77 

160 

54 

55 

78 

161 

55 

56 

79 

162 

56 

57 

80 

163 

57 

58 

81 

164 

58 

59 

82 

165 

59 

60 

83 

166 

60 

61 

84 

167 

61 

62 

85 

168 

62 

63 

86 

169 

63 

64 

87 

170 

64 

65 

88 

171 

65 

66 

89 

172 

66 

67 

90 

173 

67 

68 

91 

174 

68 

69 

92 

175 

24 

25 

48 

176 

25 

26 

49 

177 

26 

27 

50 

178 

27 

28 

51 

179 

28 

29 

52 

180 

29 

30 

53 

181 

30 

31 

54 

182 

31 

32 

55 

183 

32 

33 

56 

184 

33 

34 

57 

185 

34 

35 

58 

186 

35 

36 

59 

187 

36 

37 

60 

188 

37 

38 

61 

189 

38 

39 

62 

190 

39 

40 

63 

191 

40 

41 

64 

192 

41 

42 

65 

193 

42 

43 

66 

194 

43 

44 

67 

195 

44 

45 

68 


0.750 1 / 

0.450 1 / 

0.450 1 / 

0.450 1 / 

0.450 1 / 

0.600 1 / 
0.750 1 / 

0.750 1 / 

0.750 1 / 

0.450 1 / 

0.450 1 / 

0.250 1 / 

0.450 1 / 

0.250 1 / 

0.250 1 / 

0.750 1 / 

0.450 1 / 

0.250 1 / 

0.250 1 / 

0.250 1 / 

0.750 1 / 

0.450 1 / 

0.250 1 / 

0.250 1 / 

0.250 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.600 1 / 
0.450 1 / 

0.450 1 / 

0.450 1 / 

0.450 1 / 

0.550 1 / 

0.550 1 / 

0.650 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.650 1 / 

0.550 1 / 

0.550 1 / 

0.550 1 / 

0.550 1 / 

0.650 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.650 1 / 

0.550 1 / 


116 

0 

93 

94 

95 

96 

97 

98 

99 

217 

198 

0 

174 

175 

0 

157 

158 

159 

160 

0 

129 

130 

131 

132 

133 

104 

105 

106 

107 

108 

109 

110 

0 

70 

71 

72 

73 

74 

75 

76 

77 

78 

79 

80 

81 

82 

83 

84 

85 

86 

87 

88 

89 

90 

91 

47 

48 

49 

50 

51 

52 

53 

54 

55 

56 

57 

58 

59 

60 

61 

62 

63 

64 

65 

66 

67 
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196 45 46 69 68 

197 1 2 25 24 

198 2 3 26 25 

199 3 4 27 26 

200 4 5 28 27 

201 5 6 29 28 

202 6 7 30 29 

203 7 8 31 30 

204 8 9 32 31 

205 9 10 33 32 

206 10 11 34 33 

207 11 12 35 34 

208 12 13 36 35 

209 13 14 37 36 

210 14 15 38 37 

211 15 16 39 38 

212 16 17 40 39 

213 17 18 41 40 

214 18 19 42 41 

215 19 20 43 42 

216 20 21 44 43 

217 21 22 45 44 

218 22 23 46 45 

219 117 99 118 0 

220 105 129 128 0 

221 100 80 101 0 

222 82 104 103 0 


169 

0.0 

25000.0 

0 / NODAL LOADS 

2 

0.0 

5000.0 

0 / 

3 

0.0 

5000.0 

0 / 

4 

0.0 

5000.0 

0 / 

5 

0.0 

5000.0 

0 / 

19 

0.0 

2500.0 

0 / 

20 

0.0 

2500.0 

0 / 

21 

0.0 

5000.0 

0 / 

22 

0.0 

5000.0 

0 / 

1 

0.0 

2500.0 

0 / 

23 

0.0 

2500.0 

0 / 


71 2 0.0000000 / NODAL RESTRAINTS - 

72 2 0.0000000 / 

73 2 0.0000000 / 

74 2 0.0000000 / 

88 2 0.0000000 / 

89 2 0.0000000 / 

90 2 0.0000000 / 

91 2 0.0000000 / 

2 1 0.0000000 / 

3 1 0.0000000 / 

4 1 0.0000000 / 

5 1 0.0000000 / 

19 1 0.0000000 / 

20 1 0.0000000 / 

21 1 0.0000000 / 

22 1 0.0000000 / 

23 1 0.0000000 / 

70 2 0.0000000 / 

1 1 0.0000000 / 

92 2 0.0000000 / 


0.550 1 / 

0.550 1 / 

0.550 1 / 

0.650 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.650 1 / 

0.550 1 / 

0.550 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 

0.750 1 / 


- N1 PX PY MZ 


N1 FIXITY DEFLECTION 




diskpc.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE DSKSPC - SUBROUTINE TO GET THE DISK FREE SPACE AVAILABLE. 

PAGE .132 

; (C) Copyright Microstress Corporation 1985, 1986 
COMMENT * 

DSKSPC Is a routine designed to be called from FORTRAN as a subroutine 
to determine the available disk free space. 

[continued) 
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Mode of use: 


call DSKSPC (drive,nbyt) 

where 

drive ■ Integer variable containing the drive number (0*default, 
1-A, etc...) 

nbyt ■ Integer-4 variable containing the number of free bytes 
aval table In the disk. 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csdsks SEGMENT 'CODE* 

ASSUME CS:csdsks 

SUBTTL DSKSPC - EXECUTABLE CODE 
PAGE 

PUBLIC DSKSPC 
DSKSPC PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH DS 

; Get the drive number. 

LDS BX,DWORD PTR [BP+10] 

MOV dx,[bx] 

; Call the system function, 
mov ah,36h 
Int 21h 

; Handle parameters from calling program 
xor dx.dx 
cmp ax,0FFFFh 
Je exit 
mu I cx 
mu I bx 

; Everything done except housekeeping, 
exit: 

LDS sI,DWORD PTR [BP+6] 

MOV [si],ax 
inc si 
Inc si 

MOV [si],dx 
POP DS 
MOV SP.BP 
POP BP 
RET 8h 

DSKSPC ENDP 
csdsks ENDS 

END 


movstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE MOVSTR - SUBROUTINE TO MOVE A STRING INTO ANOTHER STRING 
PAGE ,132 

; (C) Copyright Mlcrostress Corporation 1984, 1985, 1986 
COMMENT * 

MOVSTR Is a routine designed to be called from FORTRAN as a subroutine 
to move a string into another string. 

Mode of use: 

call MOVSTR (deststr,Inidest,eosf,sourstr,inisour,Iength) 

where 

deststr « destination string name. 

Inldest * character in "deststr" where the new string will go. 
eosf = end-of-string flag to extract (*1) or to insert (=0). 
sourstr * source string name. 
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Inisour ■ character in "sourstr" where the substring starts, 
length * number of characters to be contained by the substring. 

This routine does not check the proper bounds of the indices "inidest" 
and "inisour", but it does check the validity of "length". 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csmovs SEGMENT 'CODE* 

ASSUME CS:csmovs 

SUBTTL MOVSTR - EXECUTABLE CODE 
PAGE 


PUBLIC MOVSTR 
MOVSTR PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH DS 
PUSH ES 

; Handle parameters from calling program 
LES BX,DWORD PTR [BP+22] 

MOV cx,ES:[BX] 

; Check positive request for location in destination string, 
push cx 
cmp cx,0 
jIe outbounds 
LES di.DWORD PTR [BP+26] 
mov bx,di 
scanendl: 

mov a I,es:[bx] 
cmp a I,0 
je outbounds 
cmp a I,6 
Je outbounds 
inc bx 

loop scanendl 

; The location request for the destination string is legitimate, 
pop cx 
dec cx 
add di,cx 

LDS BX,DWORD PTR [BP+10] 
mov cx.ds:[bx] 

; Check positive request for location In source string, 
push cx 
cmp cx,0 
jle outbounds 
LDS si,DWORD PTR [BP+14] 
mov bx.si 
scanend2: 

mov a I,ds:[bx] 
cmp a I,0 
Je outbounds 
cmp a I,6 
Je outbounds 
inc bx 

loop scanend2 

; The location request for the source string is legitimate, 
pop cx 
dec cx 
add si,cx 
Jmp numchars 

; There was a non-legal request. Exit leaving the strings untouched, 
outbounds: 

pop cx 
Jmp exit 

; Continue with rest of parameters, 
numchars: 

mov ax,ds 

LDS BX,DWORD PTR [BP+6] 
mov cx,de:[bx] 
cmp cx,0 


( continued) 
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j Ie exit 

LDS BX,DWORD PTR [BP+18] 
mov dx,ds:[bx] 
push dx 
mov ds.ox 

; Determine the length of the source string, 
xor dx.dx 
mov bx,st 
scanensour: 

mov al,ds:[bx] 

Inc dx 
Inc bx 
cmp a I,0 
jz endsour 
cmp a I,6 
jz endsour 
cmp dx.cx 
jl scanensour 
inc dx 

endsour: 

dec dx 
mov cx.dx 

; Determine the physical length of the destination string, 
xor dx,dx 
mov bx,di 
scanendest: 

mov al ,es:[bx] 

Inc dx 
Inc bx 
cmp a I,0 
Jz enddest 
cmp a 1,6 
Jnz nologend 
pop ax 
mov ax,1 
push ax 
nologend: 

cmp dx,cx 
jl scanendest 
Inc dx 

enddest: 

dec dx 
mov cx,dx 

; Move the substring from source into destination, 
rep movsb 

; Add an end-of-string byte if extract («1) but not If insert (*0). 
pop dx 
cmp dx,0 
jz exit 
mov a 1,6 
mov es:[di], aI 

; Everything done except housekeeping, 
exit: 

POP ES 
POP DS 
MOV SP,BP 
POP BP 
RET 18H 

MOVSTR ENDP 
csmovs ENDS 

END 


memava.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE MEMAVA - FUNCTION TO DETERMINE HOW MUCH MEMORY CAN BE ADDED 
PAGE ,132 

; (C) Copyright by Microstress Corporation 1985, 1986 
; Written by Fernando Garcla-Loygorri 
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COMMENT * 

MEMAVA is a routine designed to be called from FORTRAN as a function 
to determine how much memory is available to the last common block as 
dynamic memory. 

Mode of use: 

size - MEMAVA (var) 

where 

var « variable name of the last array in the last common block, 
size - name of the 4-byte integer variable receiving the return 
value. 

♦ 


SUBTTL FORMAL DECLARATIONS 
PAGE 

csmema SEGMENT * CODE * 

ASSUME CS:csmema 

SUBTTL MEMAVA - EXECUTABLE CODE 
PAGE 

PUBLIC MEMAVA 
memava PROC FAR 

PUSH BP 
MOV BP ,SP 
PUSH DS 

; Get total amount of room In machine, 
mov ax,40h 
mov ds,ax 
mov bx,13h 
mov ax,[bx] 
mov cI,6 
shl ax,cl 

; Get address of parameter from program. 
LDS BX,DWORD PTR [BP+6] 
mov dx,ds 
mov cI,4 
shr bx.cl 
inc bx 
add dx,bx 
sub ax,dx 

; Convert to words in DX:AX because that 
; a 4-byte integer, 
push ax 
mov cl,13 
shr ax,cl 
mov dx,ax 
pop ax 
mov cl,3 
shl ax,cl 

; Everything done except housekeeping. 
POP DS 
MOV SP,BP 
POP BP 
RET 4 

memava ENDP 
csmema ENDS 


; Save registers. 


; Point to the location in memory where 
; DOS keeps the total amount of memory: 

; Segment 40h, offset 13h-14h. 

; Get number of K In AX. 

; Multiply by 64 to get the total number 
; of paragraphs (groups of 16 bits). 

; Address of the parameter. 

; Store the segment to add later. 

; Divide by 16 to get the number of 
; paragraphs In the offset. 

; Increment for the one partially used. 

; Add it to the segment. 

; Substract it from the total, 
is where FORTRAN expects the return of 

; Save it for later. 

; Set to isolate top 3 bits. 

; Isolate them by shifting. 

; Move them to DX. 

; Recover it. 

; Multiply by 8 (words/paragraph) by 
; shifting 3 pi aces. 

; Recover the registers saved. 


; Discard the Input parameter. 


END 


chopwr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE CHOPWR - SUBROUTINE TO CHECK IF A FILE IS READY TO BE OPEN 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 

( continued) 
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COMMENT * 

Mode of use: 

call CHOPWR (name,flag) 

where 

name - string with the name of the file to be checked, 
flag ■ Integer to show success (*0) or error (<>0). 


SUBTTL FORMAL DECLARATIONS 
PAGE 

cschow SEGMENT ’CODE’ 

ASSUME CS:cschow 

SUBTTL CHOPWR - EXECUTABLE CODE 
PAGE 

PUBLIC CHOPWR 
CHOPWR PROC FAR 

PUSH BP 

MOV BP.SP 

push ds 

LDS DX,DWORD PTR [BP+101 

MOV cx.20h 

mov ah,3Ch 

Int 21h 

jb exit 

mov bx,ax 

mov ah,3Eh 

Int 21h 

xor ax,ax 

exit: 

LDS BX,DWORD PTR [BP+6] 

mov [bx],ax 

pop ds 

MOV SP,BP 

POP BP 

RET 8 

CHOPWR ENDP 
cschow ENDS 

END 


brochure.doc 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


—•INTRODUCTION—— 

The following manual Is presented In a very basic format because it 
was designed for printing on any printer. This procedure was followed 
to allow potential users of the MICROSAFE 2-D package to print the on- 
disk brochure as an assist In evaluating the programs. 

The information contained in this brochure has been extracted from the 
139 page, 8.5 x 11 Inch manual supplied with the purchased programs. 
The manual is professionally typeset in a custom binder and contains 
much more Information about the use of the programs that is summarized 
here. 

The programs are written for In-core finite element solutions of 
models with any combination of up to 400 nodes, 500 plates, 600 beams 
and 60 fasteners. The beam elements may have cross-sectional area and 
moment of Inertia and the plate elements may be triangular or 
quadrilateral membranes. 

This software package was written for the IBM-PC running DOS 2.0. It 
may also be used with the rest of IBM computers of the PC line, 
Including the PC/AT. Other computers will be able to run MICROSAFE 2-D 
as long as they are closely compatible with the IBM-PC. 
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The minimum IBM-PC configuration required is one double-sided disk 
drive and the availability of 448K memory. Bigger memory 
configurations (up to 704K or the maximum recognized by DOS, whichever 
is lower) are fully exploited by MICROSAFE 2-D to allow the analysis 
of models with larger bandwidths. In addition, the plotting program 
will require a combination graphics monitor/IBM Graphics Display 
Adapter. 

For efficiency reasons MICROSAFE 2-D is a two-part package: 

Part one is a program called SAFEPLOT used to present graphical 
displays of the model along with all input data for accuracy 
verification and assistance in correcting any data errors. 

The SAFEPLOT program generates plots of the nodal diagrams and 
structural element diagrams as well as the properties, applied loads, 
imposed deflections, restraints and coordinate values for all elements 
of the model. Windows are available for the user to see enlarged views 
of parts of the model. Details too small to be resolved in a larger 
scale view may thus be displayed. 

Part two Is a set of two programs, called SAFESOLV and SAFESOLB, used 
to conduct the actual structural analysis using the stiffness method 
finite element analysis for 2-dimenslonal structures. SAFESOLB Is a 
special version of SAFESOLV used to solve a unique class of problems. 

The analysis programs SAFESOLV and SAFESOLB present a commented 
listing of the input describing the model (optional) and tables of 
internal loads and stresses for each element. These tables include 
corner forces tabulated for each element as well as for all nodes, the 
latter showing the overall equilibrium of forces for the model. 
Deflections are also presented for all nodes. 

In addition, the package includes example input files, and other 
miscellaneous files to set up the computer and printer and to generate 
a MICROSAFE 2-D input file. 

The package has been written in the FORTRAN language and makes 
extensive use of machine language routines to increase the speed and 
the capabilities of the programs. 


—TABLE OF CONTENTS OF THE MICROSAFE 2-D MANUAL—————— 

This Is the table of contents of the MICROSAFE 2-D User’s 
Manual. Most of the information in this brochure has been extracted 
and condensed from the manual. 
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«B«Usage and copying of the MICROSAFE 2-D package===========* ! ========= 

The BYTE copy of the MICROSAFE 2-D source code is for private use 
and is not to be distributed in compiled form. Please use the complete 
MICROSAFE 2-D discs for distribution since they are safer and more 
complete for a new user. 

Users of MICROSAFE 2-D should be aware that both the computer programs 
and the User’s Manual that make up the MICROSAFE 2-D package fall 
under the scope of the 1976 Copyright Act and that MICROSTRESS 
Corporation holds a copyright on them. 

MICROSTRESS Corporation does not sell buyers a license to use its 
programs but actually sells copies of them in a manner similar to the 
way publishing companies sell books. 

The MICROSAFE 2-D programs are not copy-protected. This allows the 
legal owner to make a back-up copy as a protection against accidental 
destructIon. 

The original disk, the back-up copy or a hard disk copy may be used, 
BUT ONLY ONE OF THE ABOVE MAY BE USED AT THE SAME TIME. 

Any other use would be a violation of the copyright because the user 
paid for only one copy. On the other hand, there is no restriction on 
who uses the package or which computer runs it, but if the user wants 
to run simultaneously several copies of the program each copy must be 
purchased. Contact MICROSTRESS Corporation about conditions for 
multiple-copy purchases. 

The MICROSTRESS Corporation also authorizes the distribution of copies 
of the disks included in the MICROSAFE 2-D package, to prospective 
buyers, only if the following stipulations are satisfied: 

* The distribution of copies is for evaluation purposes ONLY. Use 
of the programs on a regular basis and/or with the intention of 
applying results is only permitted to those purchasing the 
MICROSAFE 2-D package. 

* No charge whatsoever may be collected, in any form, for the 
distribution. 

* The recipient of the evaluation copy MUST be instructed by the 
donor, in advance, of these conditions. 

* The copy must be COMPLETE, containing ALL the files included in 
the manufacturer’s release. This is to prevent the evaluation of 
incomplete copies. 

* THE PRINTED MANUAL IS NOT TO BE REPRODUCED. The on-disk 
documentation is adequate for evaluation with the many examples 
included. The printed manual contains additional documentation 
that is necessary for reliable applications of the MICROSAFE 2-D 
software to the design of structures. 

Purchasers of this software will be registered and notified of any 
enhancements and/or corrections that may be developed as long as their 
mailing addresses are kept up to date. 

The MICROSTRESS Corporation welcomes comments of any kind about the 
MICROSAFE 2-D programs and this user’s manual. We encourage the 
users of this package to write to us relating experiences and 
suggestions to make it a better product. 

As a follow up, a three dimensional version of this program is 
currently in development. 

LIMITATIONS OF LIABILITY FOR USE AND THE RESULTS OF USE 

The MICROSAFE 2-D software package has been tested by numerous 
engineers for problems of the type shown In the examples in Appendix C 
of the printed manual. New applications may uncover application 
problems beyond these and many other tests that have been run. If 
problems are detected, please notify the MICROSTRESS Corporation and 
an attempt will be made to correct the problem. 
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These programs are provided on an “as Is” basis and the 
MICROSTRESS Corporation does not guarantee, warrant or make any other 
representation regarding the use of these programs or the use of 
results generated from these programs. The user is responsible for the 
engineering validation of the program’s mathematical results and the 
suitability of this analysis to the problem being analyzed. 

-—DESCRIPTION OF FINITE ELEMENTS— 

—Nodes— 

Nodes are used to define the shape of the finite element model. A node 
is dimensionless and has the properties of physical coordinates only. 

Each node is Identified by a unique number, an integer between one and 
the total number of nodes, both Inclusive. 

Concentrated loads and node restraints are applied to the nodes 
of the model to define the load conditions to be analyzed. An adequate 
number of restraints must be defined to prevent the complete model 
from being able to translate In the x-direction, the y-direction and 
from any Inplane rotation. 

The idealized model deforms under the effect of the applied loads and 
restraints. The deformations are represented by translations and 
rotations of the nodes In the global coordinate system. 

The node restraints generate reactions from the combination of applied 
loads and Imposed deflections. These reactions are presented in the 
global coordinate system, along with any residual loads at nodes that 
are not restrained, in the SAFESOLV model solution printed output. 

MICROSAFE 2-D allows the user to create a model with up to 400 nodes. 
The amount of memory (RAM) above 448K increases the available 
bandwidth for the model rather than allowing more nodes. 

Not every node needs to be connected to the structural elements of the 
model since the program will ignore nodes that are disconnected from 
all elements. 

—Beams— 

Beam elements are used to define axial and bending stiffnesses between 
any two nodes. The shear stiffness terms are omitted since they are 
insignificant for the vast majority of problems. 

Because this version of the MICROSAFE 2-D software is used to analyze 
models that are two-dimensional the only stiffnesses that are defined 
are contained within the plane of the model. 

The sequence of the nodes defining the beam determines the local 
coordinate system. The properties of the beam and its internal loads 
are defined in the context of the local coordinate system. 

The cross—sect IonaI area of the beam may be defined as zero to 
disconnect the element from the rest of the model. The moment of 
inertia may also be defined as zero to reduce it to a rod. 

Beam loads are distributed loads and are defined by values of force 
per unit of length at each end of the beam. These distributed load end 
values may be of different magnitude and sign at each end to represent 
any desired loading. A linear variation is assumed between the two 
ends of the beam. The loads are converted to statically equivalent 
node loads at each node of the beam except for the case of rods, where 
the moments are neglected due to the lack of moment of Inertia. 

Up to 600 beams may be included in a model to be analyzed with 
MICROSAFE 2-D. 7 

—Plates— 

Plates are used to define the membrane and shear stiffness connecting 
three or four nodes. The user is free to use any sequence to define 
the nodes of a plate. 
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The geometric properties of the plate are completely defined by the 
node locations and the thickness, which Is assumed to be constant 
throughout the plate. 

The plates idealized with MICROSAFE 2-D are isotropic, so the material 
properties in the two orthogonal directions are equal. 

The triangular plates used in conventional finite element analysis 
systems are simple but do not provide precisely symmetrical 
properties. To avoid this, MICROSAFE 2-D allows the use of 
quadrilateral plates. The plate Is divided into four triangular plates 
connecting the centroid with each of the four sides of the original 
quadrilateral plate. The stiffness contribution of each of the four 
triangular plates is computed as usual and included in the global 
stiffness matrix. 

A beneficial side effect is a dramatic increase in the effective 
resolution of the grid (by as much as 40% In some models). The results 
demonstrate that the quadrilateral plates should be used whenever 
possible in finite element solutions for more accurate results. 

Plates may overlap other plates, as when fasteners are used. Since 
this is a two-dimensional program, the eccentricity of the plates in 
the thickness direction will be neglected. 

The plate internal axial loads and stresses are defined in the x-axis 
direction and in the y-axis direction and shears are defined at 45 
degrees to the x and y axis. Corner forces are also defined for each 
node of the plate and are relative to the global coordinate system. 

MICROSAFE 2-D allows a model to contain up to 500 plates. 

■■■Fasteners--* 

Fasteners are used to define a connection between any two nodes. The 
fastener element transfers an inplane load between the two nodes based 
on the relative deflection between these nodes and the stiffness of 
the fastener element. The stiffness is defined for the fastener 
element explicitly by input and is therefore not a function of the 
distance between the nodes. 

The fastener area Is only used to allow fastener shear stresses to be 
calculated and Is Irrelevant for the stiffness calculation. 

Up to 60 fasteners may be included In a model to be analysed through 
MICROSAFE 2-D. 

—DESCRIPTION OF THE INPUT DATA FILE——————————— 

...Overview of the input file**- 

The three programs that make up the MICROSAFE 2-D software package use 
a common input data file containing all the relevant Information about 
the finite element model to be analyzed. 

When the plotting program Is used to check out the data in a given 
data file, the user knows It will be correct when run with SAFESOLV. 

The Input data file is a group of lines of text in a given order that 
may be created with any editor or wordprocessing system that produces 
an ASCII output file. 

The MICROSAFE 2-D programs scan the input file sequentially ignoring 
all lines that do not contain a slash character ( / ); this way the 
user can mix lines with comments througout the entire file for future 
reference. 

The data area in the lines of the input file is filled with Individual 
numerical entries. Each entry must be separated from the others by one 
or more blank spaces and no other punctuation symbols (commas, dashes, 
...) are allowed. 

For each given line of the Input file the programs expect a certain 
number of numerical entries and each entry is supposed to be of a 
certain type and fall within a certain range of values. The entries 


(continued) 


BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 65 





July 


not complying with those rules will be rejected ond o detailed error 
message will be displayed. 

-■■Input file summary— 

The Input lines must be ordered In the following manner: 


Type 

Model size definition 


Format Description 


NN / Number-of-nodes 

NM / Number-of-materla Is 

NB / Number-of-beams 

NP / Number-of-pIates 

NF / Number-of-fasteners 

NL / Number-of-Ioaded-nodes 

NR / Number-of-lmposed-restralnts 

NI NX NY / Node X-coordlnate Y-coordlnate 


MI ME MP / 


Material Young *s-moduI us 
Poisson-ratIo 


Beam Node -1 


Node definition 

(One IIne per node 
untII all nodes 
are defined) 

Material definition 
(One IIne per 
material unt 11 all 
materials are defined) 

Beam definition BI BN1 BN2 BA BMI BM BQ1 BQ2 / 

Node-2 Area 

(One line per beam Moment-of-InertI a Material 

until all beams are D.Load-at-node-1 D.Load-at-node-2 

defined) 

Plate definition PI PN1 PN2 PN3 PN4 PT PM / Plate Node-1 

, Node-2 Node-3 

(One line per plate Node -4 Thickness Material 

untII all piates 
are defined) 

Fastener definition FI FN1 FN2 FA FS / Fastener Node -1 Node-2 

Area 

(One line per fastener Stiffness 

untII all fasteners 
are defined) 

Node loads definition LNI PX PY MZ / Node X-load Y-load Z-moment 
(One IIne per loaded 
node untII all node 
loads are defined) 

Freedom restraint definition RNI RC FD / Node Freedom Displacement 
(One line per restrained 
freedom unt II all 
restraints are defined) 

All the lines not containing a slash character (/) will be treated as 
comment lines and Ignored. 

Each Input line Is described in detail in the manual. The following is 
a typical example: 

■■■Node deflnItIon=»* 

Input: NI NX NY / 

DescrIptIon: 

NI Is the number of the node defined by the subsequent coordinates. 
Format: Integer or whole number 
Range: 1 <« NI <■ NN 
Units: None 

Remarks: No two nodes are allowed to have the same number and no 
gaps are allowed In the node number sequence which starts with 
one. See note below. 

NX is the x-coordlnate of the node along the x-axls. 

NY Is the y-coordinate of the node along the y-axis. 

Format: Real 

Range: -10E19 <■ NX or NY <« 10E19 
Units: Length 

Remarks: Several nodes can have the same coordinate values, 
as when overlapping structure is defined. 


Repeat this input line until all nodes are defined. 
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.—PLOTTING THE MODEL - SAFEPLOT PROGRAM— 

...Starting the SAFEPLOT program=== 

The input data is verified with graphical displays of the model 
elements and with properties superimposed as defined by interactive 
user input. 

The following command will run the SAFEPLOT program: 

A>d:SAFEPLOT m c I«lnpfspec 


The m, c and I-Inpfspec parameters are optional and they may be 
specified In any order. 

The m parameter is used to set the monochrome mode. This option is 
useful when using a combination monitor/display card that does not 
work well with colors other than black and white. 

The c parameter centers all plot values relative to the element 
centroid rather than make them stack around it. This is useful in fine 
grid models where the printed value is large relative to the element. 


The i-inpfspec option may be used to specify the file to be plotted. 
The inpfspec may be any valid DOS file name with drive specification, 
directory path, name and type as desired. Only the name is required. 
If not specified, the program will revert to the default drive and to 
the current directory and an extension of .INP will be automatically 
added by SAFEPLOT. 

For example: 

A>B:SAFEPLOT m I-beam C 


The program is in drive B: and the Input file Is BEAM.INP in the 
default drive A:. Both the monochrome and the centering options have 
been selected. 


...SAFEPLOT program command summary————————-—* 1 

Command: CODE options 

CODE specifies the action to be taken. 

CODE Description of function selected with CODE 

A Run Another data file - program prompts for file name. 

B Plot Beam elements as magenta lines. 

BA Display Beam Area values in magenta. 

BI Display Beam moment of Inertia values in magenta. 

BM Display Beam Material codes in magenta. 

BN Display Beam Numbers In magenta. 

C Clear screen of alt plotted and displayed data. 

D Plot Distributed beam loads as a magenta surface. 

DV Display Distributed beam load Values in magenta. 

E Get In the Enlarge mode. 

B : Move bottom of the box up. 

L : Move left side of the box to the right. 

R : Move right side of the box to the left. 

T : Move top of the box down. 

- : Reverse direction of movement. 

F Plot Fasteners as cyan lines. 

FA Display Fastener Area values in cyan. 

FN Display Fastener Numbers in cyan. 

FS Display Fastener Stiffness values In cyan. 

L Plot nodal Load vectors as cyan arrows. 

LV Display nodal Load Values In cyan. 

M Move the window - The cursor keys may also be used. 

N Plot Nodes as cyan circular symbols. 

NC Display Node Coordinate values in cyan. 

NN Display Node Numbers In cyan. 

P Plot Plates as a white surface. 

PM Display Plate Material codes in white. 

PN DIsploy Plate Numbers in white. 

PR Print display without the "Option to plot?" prompt. 


\ 
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PT Display Plate Thickness values In white. 

Q Quit - used to terminate this program run. 

R Plot type of nodal freedom Restraints as white symbols. 

RV Display node Restraint Values In white. 

S Shrink display grid to previous window. 

W Display the World - the complete model. 

Options are parameters used to specify the request with more 
detail when necessary. There are two types of options: 

Range: Used by commands that plot elements or properties of 
elements, a range Is a compact form of specifying a 
list of elements for which the request is made. 

The range Is specified with two integers, the first and 
last values of the range. If both entries are missing. 
It will plot the entire range, while If only one entry 
is present, that Item will be plotted. 

Direction: Required by the Move command to specify the 

direction of movement from the present window. It is 
specified by a single digit. 

Here are some examples: 

Option to plot? BA ■> Display all the beam area values. 

Option to plot? nn 1 18 *> Display the node numbers for all the 

nodes in the range from 1 to 18, both 
inclusive. 

Option to plot? F 23 ■> Plot the fastener numbered 23. 

Each command Is described In detail in the manual, In a similar way 

to the following examples: 

Move window 

Command: M CODE 


Range: CODE values are 1, 2, 3, 4, 6, 7, 8, or 9. 


Effect: Moves the window to the adjacent 
according to the code value. The 
the direction of movement In the 
the number 5 key to the key with 
by CODE. 


window location 
code values indicate 
numeric keypad from 
the number specified 


Remarks: The display window may be moved in one of the eight 
directions around it by using the key layout in the 
numeric pad to specify the direction: 


7 ■ up and left 8 « up 9 ■ up and right 

4 m ••ft 5 6 - right 

1 * down and left 2 ■ down 3 - down and right 

There will be an overlap of about 10% between adjacent windows to 
allow a good indexing of the images both visually and to create a 
mosaic of images obtained In a printer (see the PR command). If the 
desired movement of the window amounts to half-frame or less, the 
Enlarge command should be used (see 6.4.10). 


This command does not enlarge the Image and so the Shrink command will 
not return the window back to the previous frame from where it was 
moved but to the previous frame from where the image was actually 
enlarged. 

If numbers are to be entered from the numeric keypad, the Num Lock key 
may need to be toggled to switch the numeric key pad from the cursor 
control state to the numeric entry state. 

SPECIAL NOTE: The cursor keys uparrow, leftarrow, rightarrow and 
downarrow and the Home, Pg Up, Pg Dn and End keys will also move the 
window in the same manner as the Move command described above. They 
are less cumbersome to use, requiring only to press the key in desired 
direction relative to the central key with the number 5. 
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■*=Plot nodes***** 

Command: N inIt last 

Range: 1 <- inlt, last <■ NN 

Effect: All the nodes in the specified range of nodes will be 

plotted as rings in cyan color centered on the location 
of the node. 

If last is omitted only the node inlt will be displayed. 

If both init and last are omitted all nodes will be plotted. 

—ANALYZING THE MODEL—«— 
Starting the solution program 

The following command will run the analysis program 

A>d:SAFESOLV i*Inpfspec o-outfspec e s 

The e and s parameters may be in any order including being mixed with 
the input and output options. The e is used to print an echo of the 
input data in the output file and s is used to list the output file on 
the screen at the same time that It is created. 

The I«lnpfspec and o*outfspec parameters are also optional inputs. The 
I«inpfspec option is used to set the input file name. The o=outfspec 
option is used to specify the file to be used for all printed output. 
The sequence of the i-inpfspec and o**outfspec options may be reversed. 
If one or both of these parameter keys and associated filenames are 
omitted the program will ask for the missing file names during the 
run. 

The inpfspec and outfspec may be any valid DOS file name with optional 
drive specification, directory path and type as desired. If a file 
type is not specified, the program will use .INP for the input file 
type and .OUT for the output file type. 

The output file may be left completely unspecified (as long as 0* is 
included) and the program will automatically use the same drive, 
directory path and name as the Input file and the .OUT extension. 

As a special case the output file data can be routed to any legal 
output devtce known to DOS, In which case no output diskfile will be 
generated. An example of this is the screen device CON: or the line 
printer LPT1:. This is useful when screen output or printed output, 
but not diskfile, Is desired or where insufficient hard disk or RAM 
disk space is available. The program will ask for another disk if the 
output fills up the existing floppy disk (see below) but this option 
is not available with a fixed disk or with a RAM disk. 

For example: 

B>B:SAFES0LV I-a:beam o» e ■> The program is in drive B: 

(also the default), the input file Is BEAM.INP In drive A: and the 
output file Is BEAM.OUT In the same drive A:. The echo option has been 
seIected. 

C>$AFES0LV i-Beam o»A: «> The program is in the 

default drive C:, the input file is BEAM.INP in the default drive C: 
and the output file Is BEAM.OUT In drive A:. None of the echo or 
screen options have been selected. 

Running the solution program 

After the logo of the program is displayed in the screen the program 

will evaluate the parameters passed in the command line-If any- 

and It will prompt for the Input and output file names If missing. 

After the Input file has been specified, SAFESOLV will try to locate 
It. If the program cannot find It, It will print the following message 
on the screen: 
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ERROR : File "inpfspec" cannot be found. Try again. 

The program will then prompt for the proper file specification again. 

After the output file has been specified, SAFESOLV will try to set it 
up. 

If the program cannot open the output file, It will print the 
following message on the screen: 

ERROR : File "outfspec" cannot be open. Try again. 

The program will then prompt for the proper file specification again. 

Once SAFESOLV has located the Input file, It will proceed to read Its 
contents and will verify Its validity. The screen will show the 
progress as the data is read from the input file with a string of 
words progressing across the screen as follows: 

Size...Nodes...Materials...Beams...Plates...Fasteners...Loads . 
Restraints...End 

Each keyword corresponds to a block of lines In the input file. The 
word End marks the completion of the process of reading the input 

After reading the input file, it will start the solution of the 
resulting stiffness matrix. 

The structural relationships In the model are represented 
mathematically by a system of simultaneous equations. The number of 
equations In the system is equal to the number of degrees of freedom 
and s reported by the SAFESOLV program prior to solving the system. 
In plane stress models like those analyzed with the MICROSAFE 2-D 
package there are three degrees of freedom per node. 

The SAFESOLV programs keep the user Informed of the progress In each 
step by a plotted bar progressing between end marks on the screen. 
This helps to give an Idea of the amount of time required to finish 


The entire process will take only a few seconds for simple models like 
the beam shown In Appendix C or several minutes for bigger models For 
example. It takes approximately 5 minutes for 100 node, well-ordered 
models like the spar-bulkhead or frame examples in the same Appendix. 

The 8087 coprocessor chip significantly reduces the above solution 
t mes. If Installed, all the programs in the MICROSAFE 2-D package 
will take advantage of its presence. The switch to the 8087 is 
automatically performed by the programs and no user Intervention is 
required. 

The solution time for a matrix is very sensitive to the bandwidth 
encompassing the element stiffness terms in the stiffness matrix. The 
bandwidth depends on the order selected for the node numbering. 

Once SAFESOLV has solved the system of simultaneous equations, it will 
proceed to write the results to the output file. The screen will show 
the progress as the data is written with a progression of words like: 

Displacements...Beams...Plates...Fasteners...Reactions...End 

The program then finishes by reporting the total amount of time 
required to analyze the model for future reference and returns control 
to the operating system. 

—DESCRIPTION OF THE OUTPUT FILE— 

The SAFESOLV programs report all the information In a single output 

file. The name and destination -drive, directory path- of the 

output file is specified by the user at the beginning of each run. 

The output file is a plain text file. In ASCII form, and does not 
contain any special control characters other than the standard 
carriage-return/Iine-feed at the end of each line 
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The first lines of the output file generated by SAFESOLV contain a 
header that is handy to quickly identify the run. For example: 

MICROSAFE - STRUCTURAL ANALYSIS BY FINITE ELEMENTS 

Version: SAFESOLV (2-D) Rel. 1.0 4/02/1985 1:00:00 


Input data file : A:BEAMTEST.INP 
Output data file : C:BEAMTEST.OUT 

It shows the date and time of day when the file was created and the 
data files involved. It also displays the version and release number 
of the MICROSAFE 2-D package used. 

The input data is displayed in labeled tables as the program 
progressively reads the input file. All short form inputs, input 
positional values and restraint codes are enhanced/translated to form 
a complete readable model data description. 

*«List ing of input data==* 

The program starts by displaying the parameters that define the size 
of the mode I: 


SIZE OF THE STRUCTURE 


Number of nodes : 25 
Number of materials : 2 
Number of beams : 24 
Number of plates : 36 
Number of fasteners : 0 
Number of loaded nodes : 7 
Number of restrained degrees of freedom : 3 


and continues with the node coordinates definition: 


NODE COORDINATES 


Node Coordinate X Coordinate Y 


1 .00000 

2 20.00000 

3 40.00000 

4 60.00000 

5 10.00000 


.00000 

6.00000 

12.00000 

18.00000 

7.50000 


In the same order that they are specified in the file, not necessarily 
in a sorted form. The following table presents the material codes 
definition: 


MATERIAL PROPERTIES 


Code Young's modulus Poisson's ratio 


1 10500000. 

2 10500000. 

3 10700000. 

4 400000. 


.33000 

.33000 

.30000 

.11000 


and then the program displays the tables with the properties for the 

different types of elements- beams, plates and fasteners- in this 

order. If one or more types of elements are missing from the model 
definition, the corresponding tables will not be included. 

The table containing the beam properties looks like: 

BEAM DATA 


Beam 

I 

J 

Length 

Area 

M. Inertia 

Material Distributed Loads 

1 

1 

2 

20.881 

.2000 

.00020 

1 

.000 

.000 

2 

2 

3 

20.881 

.2000 

.00000 

1 

.000 

.000 

3 

3 

4 

20.881 

.2000 

.00512 

2 

.000 

.000 

4 

8 

9 

13.396 

.2200 

.00000 

2 

.000 

2500.000 

5 

9 

10 

13.396 

.2200 

.06250 

1 

2500.000 

5000.000 


[continued) 
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6 10 11 13.396 .2200 .12500 1 5000.000 5000 000 

7 15 16 6.100 .2400 .00000 1 .000 . 000 


The labels I and J are used to represent the end nodes of the beam. 
After the beam data table comes the table with the definition of the 
plates: 


PLATE DATA 


Plate I J K 

112 5 

2 15 8 

3 2 3 6 

4 2 9 5 


L Thickness Material 

0 .05000 3 
12 .05000 3 
0 .05500 4 
0 .06000 4 


The labels I, J, K and L are used to represent the corner nodes of the 
plate. 


The last element table will contain the Information about the defined 
fasteners: 


FASTENER DATA 

Fastener I J Area Stiffness 

1 7 22 .250000 5000000. 

2 8 23 .250000 0. 

WARNING : The fastener 2 has been disconnected from the model. 

3 9 24 .250000 5000000. 

As Is the case with the beams and plates, a warning message will be 
Included when a given element Is disconnected from the model. 

The labels I and J are used to represent the end nodes of the 
fastener. 

The last tables of the echoed Input data correspond to the node loads 
and the node restraints and they look like this: 


NODE LOADS 


Node 

PX 

PY 

MZ 

4 

.00 

1000.00 

.00 

11 

.00 

2000.00 

670000.00 

18 

.00 

5000.00 

.00 

25 

5000.00 

5000.00 

.00 

MOVEMENT 

RESTRAINTS 



Node 

Type of 

restraint 

DI sp 1 acemei 

1 

Translation 

along X axis 

.00000 

1 

Rotation about Z axis 

.00000 

4 

Trans 1 at Ion 

along X axis 

.00000 

4 

Trans 1 at Ion 

along Y axis 

.02500 

4 

Rotation about Z axis 

.00000 


The labels PX, PY and MZ are used to represent the node loads in the 
x-axis and y-axls directions and the torque around the z-axis 
respect Ively. 

*»-L I s11 ng of output dat Quu»u»B»iH»uH aUB „ a , ul „„ UISS3E 

Th« information generated by SAFESOLV about the stato of the deformed 
model is always written to the specified output file with no options 
to be specified* Again* to see the output data on the screen the user 
must specify the s option in the command line. 
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Like the Input data, the output data Is displayed In labeled tables as 
the SAFESOLV program progressively generates It. The following 
Sections explain in some detail what the different columns in the 
different tables report. 

Because of the huge amount of output data generated by SAFESOLV for 
even mid-sized models, the program constantly monitors the amount of 
space available in the disk where the output file is being written to 
prevent a fatal '‘disk full*' system error which would terminate the 
run. 


If the disk becomes full in the process of writing the output data, 
SAFESOLV will trigger a recovery process to allow the data to be split 
across different diskettes. This process will be repeated as many 
times as necessary. 


■■■Node dispIacements»«« 


The first table of the output data is always the listing of the 
displacements of the nodes in the three degrees of freedom. The table 
has the following format: 

NODE DISPLACEMENTS 


Node U 


V Omega 


1 

2 

3 

5 


.000000 

2.190833 

2.190039 

.000000 


.000000 

-.000137 

-.000230 

.000000 


.000000 

-.028178 

-.012243 

.000000 


Note that the nodes that happen to be disconnected from the model are 
not Included in this table. Node displacements at the indicated node 
are presented in a right handed Cartesian coordinate system. 

The U parameter represents the nodal deflection in the x-dlrection 
with positive x being to the right. 

The V parameter represents the nodal deflection in the y-direction 
with positive y being up. 

The Omega parameter represents the nodal rotation with positive 
being defined as counter-clockwise. 


—Beam corner forces— 

Beam corner forces are presented as loads applied to the Indicated 
ends of the beam elements. 

BEAM CORNER FORCES 


Beam 

I 

J 

FXI 

FYl 

MZI 

FX2 

FY2 

MZ2 

1 

1 

2 

-748. 

134. 

27455. 

-212. 

-134. 

-1736. 

3 

2 

3 

212. 

134. 

1736. 

-212. 

226. 

-21576. 

4 

3 

4 

512. 

-226. 

21576. 

-512. 

226. 

27585. 


Note that the beams that happen to be disconnected from the model are 
not included in this table. 

Data for node I, which corresponds to the first node of the beam, 
correspond to forces and moments with labels ending in the numeral 1. 
Data for node J, which corresponds to the second node of the beam, 
correspond to forces and moments with labels ending in the numeral 2. 

These forces are defined in the global, right handed, Cartesian 
coordinate system. 

The FXI parameters represent the corner forces in the x-direction 
with positive x being to the right. 

The FYl parameters represent the corner forces in the y-direction 
with positive y being up. 

The MZi parameters represent the end moments around the z-axis 
with a positive value being counterclockwise. 


(continued) 


BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 73 






July 


For each beam, the reported corner forces must be In static 
equilibrium with the applied beam distributed loads. For example, In 
the case of beam 1 above there Is equilibrium In the y-dlrection with 
no distributed load applied In that direction, while the distributed 
load applied In the x-dlrectlon amounts to 960 units, balancing FX1 
and FX2. 

—Beam loads and stresses— 

Beam Internal loads and stresses are presented In relation to the beam 
element local coordinate system In the following manner: 

BEAM LOADS AND STRESSES 


Beam 

I 

J 

PAX 

SAX 

SHI 

SH2 

BMI 

BM2 

1 

1 

2 

-134. 

-43. 

-748. 

212. 

-27455. 

-1736. 

3 

2 

3 

-212. 

-55. 

-134. 

226. 

-1736. 

-21576. 

4 

3 

4 

-226. 

-72. 

-512. 

-512. 

-21576. 

27585. 


Axial load (PAX) represents the force along the axis of the element, 
which coincides with the local x-axls and Is defined as being 
positive from node I to node J. Axial tension is positive and 
axial compression Is therefore shown as negative. 

The axial stress (SAX) follows the same sign conventions as PAX. 

The SHi parameters represent the shear forces at both ends of the 

beam. The shear at the second node (SH2) is defined along the 
local positive y-axis, located 90 degrees counter-clockwise from 
the x-axls. The shear at the first node (SHI) is defined In the 
opposite direction to SH2. 

The BMi parameters represent the bending moments at the ends of the 
beam. Positive bending Is defined as producing compression in 
the positive y-surface of the beam. Therefore, the positive 
bending moment at the second node (BM2) Is counterclockwise and 

the positive bending moment at the first node Is clockwise. 

»==Plate corner forces**®* 

Plate corner forces are presented as forces applied to the nodes at 

the corners of the plate element. 

PLATE CORNER FORCES 


Plate I 

J 

K 

L FXI •• v FYI 

FX2 

FY2 

FX3 

FY3 

FX4 

FY4 

1 1 

2 

5 

0 -5751. -1883. 

824. 

2306. 

4927. 

-423. 

0. 

0. 

2 2 

3 

10 

9 -6735. -2116. 

3141. 

-125. 

2461. 

2997. 

1132. 

-756. 

4 2 

9 

5 

0 3292. -1345. 

1310. 

1703. 

-4602. 

-358. 

0. 

0. 

5 2 

6 

9 

0 -3891. -1370. 

2731. 

2703. 

1160. 

-1333. 

0. 

0. 


The plates that happen to be disconnected from the model are not 
included In this table. Data for node I, which corresponds to the 
first node defined for the plate, Is presented under labels ending in 
the numeral 1. Data for nodes J, K and L is presented in a similar 
way. 

These forces are defined in the global, right handed, Cartesian 
coordinate system. 

The FXi parameters represent the corner forces In the x-direction 
with positive x being to the right. 

The FYi parameters represent the corner forces In the y-dlrection 
with positive y being up. 

For each plate, the reported corner forces must be In static 
equilibrium. The user may check that it is true by adding all the 
corner forces of each plate in a given direction, as is the case in 
the example table shown above. 

**«Plate load intensities and stresses— 
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The table following the plate corner forces displays the plate load 
intensities and stresses and looks like: 
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PLATE LOAD INTENSITIES AND STRESSES 


Plate 

TMAX 

I 

J K L 
Ang 1 e 

PIX 

PIY 

TXY 

1 

22282. 

1 

2 5 0 
62. 

1461. 

237. 

931. 

2 

9806. 

2 

310 9 
64. 

811. 

212. 

388. 

4 

8427. 

2 

9 5 0 
84. 

1151. 

327. 

89. 

5 

14446. 

2 

6 9 0 
55. 

683. 

173. 

676. 


SX 

SY 

TAU 

SMAX 

SMIN 

29219. 

4740. 

18620. 

39262. 

-5303 

16225. 

4233. 

7758. 

20035. 

424 

23012. 

6542. 

1790. 

23204. 

6349 

13657. 

3455. 

13515. 

23002. 

-5890 


The PIX, PIY and TXY values represent the plate load intensities in 
the x, y and xy directions respectively. 

The SX, SY and TAU values represent the plate stresses in the x, y and 
xy directions respectively. 

The SMAX, SMIN and TMAX values represent the plate principal stresses: 
maximum axial stress, minimum axial stress and maximum shear 
stress. 

The Angle parameter shows the orientation of the principal stresses 
In the global coordinate system. 

The principal stress data are calculated with the traditional 
Mohr’s circle method. 


The xy direction is used to indicate the 45 degree diagonal between 
the x and y axes for shear flows (TXY) and shear stresses (TAU). 

For quadrilateral plates, the stress matrix is formed by assembling 
the stress matrices of four Individual triangular plate elements. This 
method prevents the unsymmetricaI error associated with the usual 
stiffness matrix for a two-plate idealization of a quadrilateral 
plate. The data values presented are an average of the values of the 
triangular subelements. 


■—Plate stresses at node points— 


The SAFESOLV program presents average stresses for the plate elements 
at each node. This Is done In a table similar to the following 
examp Ie: 

PLATE STRESSES AT NODE POINTS 


Node Coord- X Coord- Y SX SY TAU SMAX SMIN TMAX Angle 


1 .00000 .00000 24478. 8639 

2 40.00000 12.00000 22816. 4372 

3 80.00000 24.00000 13179. 2650 

5 120.00000 36.00000 7465. 9091 

6 20.00000 15.00000 19249. 8462 


21085. 39081. 

-5965. 

22523. 

55 

11074. 28005. 

-817. 

14411. 

65 

8483. 17898. 

-2070. 

9984. 

61 

8306. 16623. 

-67. 

8345. 

42 

13414. 28313. 

-602. 

14458. 

56 


Only the nodes that are used to define plates will be included in the 
table. 


These averages are derived from the stresses in actual triangular 
plates and in triangular subelements used in the idealization of 
quadrilateral plates. For this reason stresses may be higher or lower 
at the nodes than the average plate element stresses shown In the 
previous Section. 


■■■Fastener forces and stresses— 

After the plate data has been reported in the output file, SAFESOLV 

includes a table with forces and stresses In the fasteners-If any 

are present: 


(continued) 
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FASTENER FORCES AND STRESSES 


Fastener 

I 

J 

FX 

FY 

F 

Ang 1 e 

Stress 

1 

7 

22 

88. 

-1. 

88. 

-1. 

351. 

2 

8 

23 

29. 

2. 

29. 

3. 

115. 

3 

9 

24 

84. 

-1. 

84. 

-1. 

334. 


Node I corresponds to the first node of the fastener and node J 
corresponds to the second node. 

The FX and FY values represent the fastener load transfer In the x and 
y directions respectively. 

The F and Angle values represent the vector sum of the load transfer 

components and its line of action relative to the global x-axis. 

The Stress value represents the fastener shear stress due to load 
transfer. 

=«Node internal forces and react ions— 

A summation of all element corner forces and applied nodal loads for 

each node is presented in this section. The results of this summation 

show the reaction forces for each node. 

NODE INTERNAL FORCES AND REACTIONS 


Node Coord-X 

Coord-Y 

FX 

FY 


MZ 


1 .00000 

.00000 

-748. Reaction 

134. 

React ion 

27455. 

React ion 

2 .00000 

96.00000 

0. 

0. 


0. 


3 432.00000 

96.00000 

0. 

0. 


0. 


4 432.00000 

.00000 

-512. Reaction 

226. 

React ion 

27585. 

Reaction 

The coordinates for each 

node followed by the force in 

the x- 


direction, the 

i force In 

the y-dlrectlon 

and 

the moment 

In the 

z- 


direction are presented. 

If the model idealization results In a poorly or Ill-conditioned 
matrix, the inaccuracy will be shown as a nonzero value for nodes with 
no restrained degrees of freedom. Each restrained degree of freedom is 
Indicated by the word Reaction printed after the force value to aid In 
identifying the reactions. A review of this data is necessary to prove 
the accuracy of the solution. 


—PROGRAM MESSAGES————————————— 

There are three kinds of messages that the MICROSAFE 2-D programs 

provIde: 

Informative messages: The ones the programs use to keep you up to date 
about what they are doing. 

Warning messages: The programs inform the user of facts that may be 
right but, if wrong, may have disastrous consequences. 

Error messages: Diagnostics the programs make when they encounter a 

situation they cannot handle and that requires some changes to be 
introduced by the user. 

The following is a sample of the Section In the manual that describes 

the error messages: 

Message: 

ERROR : INCOMPATIBLE TYPE OF NUMERIC ENTRY IN INPUT LINE. 

Encountered In line 1066 of file WRNGTYPE.INP. 


|108 192 199 2.4 0 .020 1 /| 


Reading properties of plate 108 it was expected to find the index of 
the third node of the plate - an integer between 1 and 400 - as the 
fourth entry. 

Occurrence: Both the SAFEPLOT and the SAFESOLV programs. 
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Explanation: One of the entries In the line is of a type (integer, 
real, ... ) incompatible with the type of the expected data. 

The arrows in the error message point to the character responsible for 
the type change and the following message states the required type for 
the entry. 

Action: Check the input file and replace the entry with the Incorrect 
type. 

Execute the program again with the modified input file. 

—EXAMPLES————————————————————————— 

Beam With Multiple Supports 

This example shows the program in one of its simplest uses. The model, 
specified In file BEAM.INP, represents a beam of constant properties 
with fully fixed supports at the left end and a simple support near 
mid-span. A 500 pound per inch distributed load is applied between the 
supports and nodal loads are applied at the free end of the 
cantilevered portion of the beam. 

THIS IS FILE BEAM.INP AND WAS USED FOR EXAMPLE #1 IN THE DOCUMENT 
This model represents a beam fixed at the left end with a mid-span 
support. 

The left span has distributed loads and the right end has concentrated 
loads. 

9 / # nodes 

1 / # materials 

8 / # beams 

0 / # plates 

0 / # fasteners 

1 / # loaded nodes 

4 / f specified displacements 

1 0.0 0.0 / nodal coordinates 

2 2.5 0.0 / 

3 5.0 0.0 / 

4 7.5 0.0 / 

5 10.0 0.0 / 

6 15.0 0.0 / 

7 20.0 0.0 / 

8 25.0 0.0 / 

9 30.0 0.0 / 


1 

10 

.3E6 0.33 / 

material 

propertIes 

1 

1 

2 

0.5 

1.0 

1 

-500. 

-500. 

/ beams 

2 

2 

3 

0.5 

1.0 

1 

-500. 

-500. 

/ 

3 

3 

4 

0.5 

1.0 

1 

-500. 

-500. 

/ 

4 

4 

5 

0.5 

1.0 

1 

-500. 

-500. 

/ 

5 

5 

6 

0.5 

1.0 

1 

0. 

0. 

/ 

6 

6 

7 

0.5 

1.0 

1 

0. 

0. 

/ 

7 

7 

8 

0.5 

1.0 

1 

0. 

0. 

/ 

8 

8 

9 

0.5 

1.0 

1 

0. 

0. 

/ 


9 1000. -500. 10000. / applied nodal loads PX PY MZ 

1 1 0.0 / specified displacements 

1 2 0.0 / 

1 3 0.0 / 

5 2 0.0 / 


—Skin Lap-splice With Fasteners————————————— 

The lap-splice model represents two .050 Inch thick sheet metal 
rectangles that are fastened together with three fasteners. The sheet 
metal parts are defined in separate regions so that they do not 
overlap and thus the plot of each part does not interfere with the 
plot of the other part. 

Fasteners transfer loads from one node to another according to the 
relative deflections of the nodes, and the actual locations of the 

nodes are Ignored. For this reason parts being fastened together may 
be located anywhere the user desires. 


(continued) 
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THIS IS FILE SPLICE.INP : EXAMPLE #2o IN THE MANUAL. 
The model represents two pieces of sheet metal, 
represented by QUADRILATERAL plates, fastened together 
with three rivets. These pieces are positioned 
s1de-by-sIde to avoid overlapping and allow the plots 
to be easier to see. 

30 / number of nodes 

1 / number of materials 

0 / number of beams 

16 / number of plates 

3 / number of fasteners 

3 / number of loaded nodes 

6 / number of restrained degrees of freedom 


1 

0.2 

0 / node defin11Ions 

2 

1.2 

0 / 

3 

2.2 

0 / 

4 

3.2 

0 / 

5 

4.2 

0 / 

6 

0.2 

1 / 

7 

1.2 

1 / 

8 

2.2 

1 / 

9 

3.2 

1 / 

10 

4.2 

1 / 

11 

0.2 

2 / 

12 

1.2 

2 / 

13 

2.2 

2 / 

14 

3.2 

2 / 

15 

4.2 

2 / 


16 0 3 / 

17 1 3 / 

18 2 3 / 

19 3 3 / 

20 4 3 / 

21 0 4 / 

22 1 4 / 

23 2 4 / 

Other example models are defined on the MICROSAFE DISK #1 


********** MICROSAFE 2-D PURCHASE FORM ********** 


Purchased from: MICROSTRESS Corporation 
10950 FOREST AVE SO. 
SEATTLE. WASHINGTON, 98178 


Federal Tax No. #: 91-1287902 

Wash. State Tax #: C 600 572 139 
Purchase date: / / 


PRODUCT DESCRIPTION 

QTY 

PRICE PRICE 
EACH EXTENDED 

SAFESOLV and SAFESOLB - solution program 


$50 

SAFEPLOT - plotting program 


$50 

MICROSAFE PACKAGE - all above programs 


$75 


TOTAL PURCHASE PRICE « 


PLEASE MAKE CHECKS PAYABLE TO: MICROSTRESS Corporation 


The above amounts include state and local taxes within Washington 
state and all postage within the USA. Please include appropriate 
postage and instructions for mailing outside of the USA. 

Formal documentation is included with all programs shown above. 
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The undersigned has read the "Usage and Copying of the MICROSAFE 2-D 
package" and "Limitations of Liability for Use and the Results of Use" 
sections of the MICROSAFE 2-D Manual Brochure and agrees to abide by 
these terms and conditions. 


MAILING ADDRESS: 




Signature 

_ name 

_ street address or P.0, box 

_ city, state and ZIP code 


/ 


setstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE SETSTR - SUBROUTINE TO MARK THE PHYSICAL END OF A STRING 
PAGE ,132 


; (C) Copyright Microstress Corporation 1984, 1985, 1986 


COMMENT * 

SETSTR is a routine designed to be called from FORTRAN as a subroutine 
to mark the physical end of a string at the location specified by the 
Input. 


Mode of use: 
where 


cal I SETSTR (i.string) 


i - index to specify the location in the string of the character 
where the end-of-strIng mark is to be written, 
string ■ name of the string (variable of type CHARACTER) to be 
marked. 


This routine only checks the index "i" is greater than zero. 
♦ 


SUBTTL FORMAL DECLARATIONS 
PAGE 


cssets SEGMENT 'CODE* 

ASSUME CS:cssets 

SUBTTL SETSTR - EXECUTABLE CODE 
PAGE 

PUBLIC SETSTR 
SETSTR PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH ds 

LDS BX,DWORD PTR [BP+10] 

MOV CX,[BX] 

DEC CX 

; Check positive request, 
cmp cx,0 
jge inbounds 
xor cx.cx 

; Mark the physical end of the string, 
inbounds: 

LDS BX,DWORD PTR [BP+6] 

ADD BX.CX 
XOR AL,AL 
MOV [BX],AL 


(continued) 
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; Exit. 

POP ds 
MOV SP.BP 
POP BP 
RET 8H 


SETSTR ENDP 
cssets ENDS 

END 


time.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE TIME - SUBROUTINE TO GET THE TIME OF THE DAY 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * * 

TIME is a routine designed to be called from FORTRAN as a subroutine 
to access the time of the day from the system. 

Mode of use: 

call TIME (hour.minute,second,hundredth) 

where 

hour - integer variable containing the hour of the dayth. 
minute - integer variable containing the minute of the hour, 
second * integer variable containing the second of the minute, 
hundredth « integer variable containing the hundredths of 
the second. 

* 


SUBTTL FORMAL DECLARATIONS 
PAGE 

cstime SEGMENT ’CODE’ 

ASSUME CS:cstime 

SUBTTL TIME - EXECUTABLE CODE 
PAGE 

PUBLIC time 

time PROC FAR 

PUSH BP 

MOV BP,SP 

PUSH DS 

; Call the system function, 
xor ax,ax 

mov ah,2Ch 

int 21h 

; Handle parameters from calling program 
xor ax,ax 

mov al.dl 

LDS BX,DWORD PTR [BP+6] 

MOV [BX],ax 

mov al,dh 

LDS BX,DWORD PTR [BP+10] 

MOV [BX],ax 

mov a I,cl 

LDS BX,DWORD PTR [BP+14] 

MOV [BX],ax 

mov al.ch 

LDS BX,DWORD PTR [BP+18] 

MOV [BX],ax 

; Everything done except housekeeping, 
exit: 

POP DS 

MOV SP.BP 
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J uly 



POP 

BP 


RET 

10H 

time 

ENDP 


cstime 

ENDS 


END 



pakstr. 

asm 



"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE PAKSTR - SUBROUTINE TO PACK A STRING 
PAGE .132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT » 

PAKSTR is a routine designed to be called from FORTRAN as a subroutine 
to pack a string by eliminating blank characters at both ends. 

Mode of use: 

call PAKSTR (string) 

where 

string - name of the string (variable of type CHARACTER) to be 
reset. 


* 


SUBTTL FORMAL DECLARATIONS 
PAGE 

cspaks SEGMENT ’CODE* 

ASSUME CS:cspaks 

SUBTTL PAKSTR - EXECUTABLE CODE 
PAGE 

PUBLIC PAKSTR 
PAKSTR PROC FAR 

PUSH BP 
MOV BP,SP 
PUSH ds 

LDS SI,DWORD PTR [BP+6] 
mov DI,s! 

; Scan for the first non blank character 
scanonbIank: 

mov a I,[si] 

Inc si 
cmp a I,32 
Jz scanonblank 

; Move characters until any end-of-string mark is found, 
dec si 
xor cx,cx 

scanend: 

mov a I,[si] 
cmp a I,0 
jz scanback 
cmp a I,6 
jz scanback 
mov [di],al 
Inc 8 I 
Inc di 
Inc cx 
jmp scanend 

; Move back until a non-blank character or the beginning of the string is found 
scanback: 9 

cmp cx,0 
je logical 
dec cx 


(continued) 
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dec dt 
mov a I, [d i ] 
cmp a I,32 
jz scanback 
inc dl 

; Add a logical end-of-strIng mark If necessary, 
logical: 



cmp dl,sI 
jz exit 
mov a 1,6 
mov [di],a 

; Exit 


exit: 

POP ds 

MOV SP.BP 
POP BP 

RET 4 

PAKSTR 

END P 

cspaks 

ENDS 

END 


confrm. 

asm 


"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE CONFRM - SUBROUTINE TO CONFIRM AN OPERATION BY PRESSING ANY KEY 
PAGE ,132 

; (C) Copyright Microstress Corporation 1985, 1986 

COMMENT * * 

Mode of use: 

call CONFRM 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csconf SEGMENT ’CODE* 

ASSUME CS:csconf 

SUBTTL CONFRM - EXECUTABLE CODE 
PAGE 

PUBLIC confrm 
confrm PROC FAR 

PUSH BP 

MOV BP.SP 

mov a I,8 

mov ah,0Ch 
int 21h 

MOV SP.BP 

POP BP 

RET 

confrm ENDP 
csconf ENDS 
END 
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pacer.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrf. July, page 199. 


TITLE PACER - SUBROUTINE TO PACE THE EXECUTION OF A PROGRAM 
PAGE ,132 


; (C) Copyright Microstress Corporation 1984, 1985, 1986 


COMMENT * * 

PACER is a routine designed to be called from FORTRAN as a subroutine to 
plot a symbol in the screen to show a program is running. 


Mode of use: 

every time is 
* 


caI I PACER 

required to show the pace. 


SUBTTL FORMAL DECLARATIONS 

PAGE 

CSPACE SEGMENT ‘CODE* 

ASSUME CS:CSPACE 

SUBTTL PACER - EXECUTABLE CODE 

PAGE 

PUBLIC PACER 

PACER PROC FAR 

PUSH BP 
MOV BP.SP 
mov ah,10 
xor bh,bh 
mov cx,1 
mov a 1,176 
Int 10h 
mov ah,3 
xor bh.bh 
int 10h 
mov ah,2 
inc dl 
int 10h 
MOV SP,BP 
POP BP 
RET 

PACER ENDP 

CSPACE ENDS 

END 


logpsI.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE LOGPSL - SUBROUTINE TO PUT IN THE SCREEN THE LOGO OF THE PROGRAM 
PAGE ,132 

; (C) Copyright Fernando G. Loygorri 1984, 1985, 1986 

COMMENT * 

Mode of use: 

cal I logpsI 

* 


SUBTTL FORMAL DECLARATIONS 
PAGE 

(continued) 
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cslogd SEGMENT 'CODE* 

ASSUME CS:cslogd 


; Image of the logo: 


Image D6 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 
DB 


ivvvvvvvvvvvvvvvvvvwvvvvwvvvvvvvwvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv( 


V 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 


tm 

.SAFE 

///////// 

Stress Analysis using Finite Elements 
Version : 2-D Release : 1.0 

•6688888856666666666658666668686686666668686686666888886868666/ 
TCompMed from BYTE Magazine source code: Not for d i st r l but ionT 
e668588585866866886588o668566656666666666668858655666686666666X, 
Copyright (C) 1985, 1986 by Microstress Corporation 
10950 Forest Av. S Seattle, WA. 98178 
All rIghts reserved 


7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 

7 


Ovvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv] 


SUBTTL LOGPSL - EXECUTABLE CODE 
PAGE 

PUBLIC logpsl 
logpsl PROC FAR 


PUSH 

MOV 

mov 

Int 

mov 

Int 

cl I 

push 

mov 

mov 

mov 

mov 

add 

mov 

mov 

xor 

push 

mov 

mov 

mov 

mov 

char: 

retracel: 

In 

test 

jnz 

retrace2: 

In 

test 

Jz 

mov 

stosb 

Inc 

I nc 

loop 

pop 

pop 

st i 

mov 

int 

mov 

xor 


BP 

BP ,SP 
ax ,3 
10h 

ax,503h 
10h 


es 

ax,40h 
es ,ax 
di,63h 
dx.es:[di] 
dx, 6 

ax,0b800h 
e8, ax 
di .di 
ds 

ax.cslogd 
ds ,ax 

si,offset image 
cx.1279 


a I , dx 
a! .1 

retracel 

a I ,dx 
al .1 

retrace2 
al,[si ] 

si 

di 

char 

ds 

es 

ax,500h 
10h 

dx.1300h 
bx.bx 
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mov 

ah, 2 


Int 

10h 


MOV 

SP,BP 


POP 

BP 


RET 


logps1 

ENDP 


cslogd 

ENDS 


END 




intsgn.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE INTSGN - FUNCTION TO DETERMINE THE SIGN OF AN INTEGER 
PAGE ,132 

; (C) Copyright Microstress Corporation 1985, 1986 
COMMENT * 

INTSGN Is a routine designed to be called from FORTRAN as a function 
to return the sign of an Integer. 

Mode of use: 

sign - INTSGN (integer) 

where 

sign - value returned by the function, the integer sign, 
integer - name of the integer (variable of type INTEGER-2) whose 
sign is requested. 

♦ 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csisgn SEGMENT * CODE * 

ASSUME CS:csisgn 

SUBTTL INTSGN - EXECUTABLE CODE 
PAGE 

PUBLIC INTSGN 
INTSGN PROC FAR 

PUSH BP 
MOV BP,SP 
PUSH ds 

LDS BX,DWORD PTR [BP+6] 
mov cx,[bx] 
cmp cx,0 
Jg positive 
Jl negative 
xor ax,ax 
Jmp exit 
posItIve: 

mov ax, 1 
jmp exit 
negative: 

mov ax,0ffffh 
; Value Is returned in AX. 
exit: 

POP ds 
MOV SP.BP 
POP BP 
RET 4H 

INTSGN ENDP 
csisgn ENDS 

END 


[continued] 
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constr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE CONSTR - SUBROUTINE TO CONCATENATE TWO STRINGS 
PAGE .132 

: (C) Copyright Microstress Corporation 1984, 1985, 1986 

COMMENT * .... 

CONSTR is a routine designed to be called from FORTRAN as a 

to concatenate two strings. 

Mode of use: 

call CONSTR (deststr.eourstr) 

where 

deststr *■ destination string name. 

sourstr - source string name to be concatenated to 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

cscons SEGMENT ’CODE* 

ASSUME CS:cscon8 

SUBTTL CONSTR - EXECUTABLE CODE 
PAGE 

PUBLIC CONSTR 
CONSTR PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH DS 
PUSH ES 

j Locate end of the destination string (logical or physical) 

LES dI,DWORD PTR [8P+10] 
dec d! 
scanendl: 

Inc di 

mov a I,es:[di] 
cmp a I,0 
je exit 
cmp a I,6 
jne scanendl 
mov bx.di 

; Locate the physical end of the destination string. 
scanend2: 

Inc bx 

mov a I,es:[bx] 
cmp a I,0 
jne scanend2 
sub bx.di 
mov dx.bx 

; Locate end of the source string (logical or physical) 

LDS si,DWORD PTR [BP+6] 
mov bx,si 
xor cx.cx 
scanendsource: 

mov a I,[bx] 
cmp a I,0 
Je foundend 
cmp a I,6 
je foundend 
inc bx 
Inc cx 

jmp scanendsource 
; Check if there is enough room, 
foundend: 

cmp dx,cx 
jge copy 


subroutine 


••deststr”. 
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mov cx,dx 

; Tack the source string at the end of the destination string, 
copy: 

rep movsb 

; Add a logical end-of-string mark If not physical end already, 
mov al,es:[di] 
cmp a I,0 
jz exit 
mov a I,6 
mov es:[dl],al 

; Everything done except housekeeping, 
exit: 

POP ES 
POP DS 
MOV SP.BP 
POP BP 
RET 8 

CONSTR ENDP 
cscons ENDS 

END 


I enstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE LENSTR - FUNCTION TO DETERMINE STRING LENGTH 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * * 

LENSTR i8 a routine designed to be called from FORTRAN as a function 
to return the length of a string. 

Mode of use: 

length - LENSTR (string) 

where 

length - 2-byte integer returned, the string length, 
string - name of the string (variable of type CHARACTER) whose 
length is requested. 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

cslens SEGMENT 'CODE* 

ASSUME CS:cslen8 

SUBTTL LENSTR - EXECUTABLE CODE 
PAGE 

PUBLIC Ienstr 
I enstr PROC FAR 

PUSH BP 

MOV BP,SP 

PUSH ds 

LDS BX,DWORD PTR [BP+6] 

xor ax,ax 

scanend: 

mov cI,[bx] 

cmp cI,0 

je exit 

cmp cl,6 

je exit 

i nc bx 

Inc ax 

jmp scanend 

; Value is returned In AX. 
exit: 

{continued) 
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POP 

ds 


MOV 

SP,BP 


POP 

BP 


RET 

4 

1enstr 

ENDP 


cs1ens 

ENDS 


END 

Iwcstr 

.asm 



"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE LWCSTR - SUBROUTINE TO PUT A STRING IN LOWERCASE 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * 

LWCSTR Is a routine designed to be called from FORTRAN as a subroutine 
to set all the alphabetic characters to lowercase. 

Mode of use: 

caI I LWCSTR (string) 

where 

string ■ name of the string (variable of type CHARACTER) to be 
converted to lowercase. 

* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

cslwcs SEGMENT ’CODE* 

ASSUME CS:cslwcs 

SUBTTL LWCSTR - EXECUTABLE CODE 
PAGE 

PUBLIC I westr 
Iwcstr PROC FAR 


PUSH 

bp 


MOV 

bp.sp 


PUSH 

ds 


LDS 

BX,DWORD 

PTR [BP+61 

character: 

CMP 

BYTE PTR 

[bx],0 

je 

exit 


CMP 

BYTE PTR 

[bx],6 

J« 

exit 


CMP 

BYTE PTR 

[bx].’A* 

JB 

next 

CMP 

BYTE PTR 

[bx],*Z* 

JA 

next 

OR 

BYTE PTR 

[bx],32 

next: 

INC 

bx 



Jmp character 


exit: 

pop 

ds 


MOV 

sp.bp 


POP 

bp 


RET 

4 

Iwcstr 

ENDP 


cs1wes 

ENDS 


END 




88 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 








July 


modstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE MODSTR - SUBROUTINE TO MODIFY A STRING BY REPLACING A CHARACTER 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * 

MODSTR is a routine designed to be called from FORTRAN as a subroutine 
to modify a string by replacing a character in it. 

Mode of use: 

call MODSTR (deststr,posItIon,asciic) 

where 

deststr * destination string name. 

position « character in "deststr" to be replaced. 

ascilc ■ ASCII code of the character to be put in the string. 

♦ 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csmods SEGMENT 'CODE* 

ASSUME CSicsmods 

SUBTTL MODSTR - EXECUTABLE CODE 
PAGE 

PUBLIC modstr 
modstr PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH DS 

; Handle parameters from calling program 
LDS BX,DWORD PTR [BP+6] 

MOV ax,DS:[BX] 

LDS BX,DWORD PTR [BP+10] 

MOV cx,DS:[BX] 

LDS bx,DWORD PTR [BP+14] 

; Check positive request for location in destination string, 
cmp cx,0 
jle exit 
dec cx 
add bx,cx 
mov [bx],al 

; Everything done except housekeeping, 
exit: 

POP DS 
MOV SP,BP 
POP BP 
RET 0CH 

modstr ENDP 
csmods ENDS 


f i Istr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE FILSTR - SUBROUTINE TO FILL A STRING WITH A GIVEN CHARACTER 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985 

[continued ) 
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COMMENT * 

FILSTR i8 a routine designed to be called from FORTRAN as a subroutine 
to fill a string with a character specified as a parameter. 

Mode of use: 

cal I FILSTR (l.string) 

where 

I - ASCII code of the character to be used to fill the string, 
string ■ name of the string (variable of type CHARACTER) to be 

reset. 


* 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csflls SEGMENT * CODE' 

ASSUME CS:csflls 

SUBTTL FILSTR - EXECUTABLE CODE 
PAGE 

PUBLIC FILSTR 
FILSTR PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH ds 

LDS BX,DWORD PTR [BP+10] 
mov ah,[bx] 

LDS BX,DWORD PTR [BP+6] 

; Write character until an end-of-strIng mark is found, 
scanend: 

mov a I,[bx] 
cmp al,0 
Jz exit 
cmp al,6 
jz exit 
mov [bx],ah 
Inc bx 
Jmp scanend 

; Exit 
exit: 

POP ds 
MOV SP,BP 
POP BP 
RET 8 

FILSTR ENDP 
csflls ENDS 

END 


sizstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE SIZSTR - FUNCTION TO DETERMINE STRING SIZE 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * 

SIZSTR Is a routine designed to be called from FORTRAN as a function 
to return the size of a string. 

Mode of use: 

size - SIZSTR (string) 

where 

size - 2-byte integer returned by the function, the string size, 
string * name of the string (variable of type CHARACTER) whose 
length is requested. 
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SUBTTL FORMAL DECLARATIONS 
PAGE 


cssizs 

SEGMENT 

’CODE* 


ASSUME 

CS:cssizs 

SUBTTL 

SIZSTR - 

EXECUTABLE CODE 

PAGE 



PUBLIC 

s 1 zstr 


s i zstr 

PROC FAR 


PUSH 

BP 


MOV 

BP ,SP 


PUSH 

ds 


LDS 

BX,DWORD PTR [BP+6] 


xor 

ax, ax 

scanend 

: 



mov 

cl,[bx] 


inc 

ax 


cmp 

cl ,0 


J« 

exit 


inc 

bx 


imp 

scanend 

; Value 

is returned in AX. 

exit: 




POP 

ds 


MOV 

SP.BP 


POP 

BP 


RET 

4h 

sizstr 

ENDP 


css izs 

ENDS 


END 




endstr.asm 


"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE ENDSTR - SUBROUTINE TO MARK THE LOGICAL END OF A STRING 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985, 1986 
COMMENT * 

ENDSTR is a routine designed to be called from FORTRAN as a subroutine 
to mark the logical end of a string at the location specified by the 
i nput. 

Mode of use: 

call ENDSTR (i,string) 

where 

i ■ index to specify the location in the string of the character 
where the Ioglcal-end-of-string mark is to be written, 
string - name of the string (variable of type CHARACTER) to be 
marked. 

♦ 

SUBTTL FORMAL DECLARATIONS 
PAGE 

csends SEGMENT ’CODE* 

ASSUME CS:csends 

SUBTTL ENDSTR - EXECUTABLE CODE 
PAGE 


[continued] 
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PUBLIC ENDSTR 
ENDSTR PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH ds 

LDS BX,DWORD PTR [BP+10] 

MOV CX,[BX] 

DEC CX 

; Check positive request, 
cmp cx,0 
Jge Inbounds 
xor cx,cx 

; Check the logical mark Is not beyond the physical mark. 
I nbounds: 

LDS BX.DWORD PTR [BP+6] 

scanend: 

mov a I,[bx] 
cmp a I.0 
jz exit 
cmp cx.0 
Jz mark 
dec cx 
Inc bx 
jmp scanend 

; Mark the logical end of the string, 
mark: 

mov AL.6 
MOV [BX],AL 

; Exit, 
exit: 

POP ds 
MOV SP.BP 
POP BP 
RET 8H 

ENDSTR ENDP 
csends ENDS 

END 


deIf11.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE DELFIL - SUBROUTINE TO DELETE A FILE 
PAGE ,132 

; (C) Copyright Microstress Corporation 1985, 1986 
COMMENT * 

DELFIL is a routine designed to be called from FORTRAN as a subroutine 
to delete a file specified with drive (optional), path (optional), name 
and extension in an ASCIIZ string. 

Mode of use: 

call DELFIL (flname) 

where 

flname - name of the file (variable of type CHARACTER) to be 
deleted. 


SUBTTL FORMAL DECLARATIONS 
PAGE 


csdelf SEGMENT * CODE * 

ASSUME CS:csdelf 

SUBTTL DELFIL - EXECUTABLE CODE 
PAGE 
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PUBLIC delfil 
deIfiI PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH ds 

LDS dx,DWORD PTR [BP+6] 

; Use Function Call from DOS 2.0. 
mov ah,41h 
Int 21h 
POP ds 
MOV SP.BP 
POP BP 
RET 4 

delfil ENDP 
csdelf ENDS 

END 


locstr.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE LOCSTR - SUBROUTINE TO LOCATE A STRING INSIDE ANOTHER STRING 
PAGE .132 

; (C) Copyright Microstress Corporation 1984,1985, 1986 
COMMENT * 

LOCSTR is a routine designed to be called from FORTRAN as a function 
to locate a string inside another string. 

Mode of use: 

pos ■ LOCSTR (1,stringl,string2) 

where 

i ■ location where the search in the destination string is to 
start. 

strlngl « name of the destination string (variable of type 

CHARACTER) where the source string is to be searched. 
string2 « name of the source string (variable of type CHARACTER) 
to be located inside the destination string. 

♦ 

SUBTTL FORMAL DECLARATIONS 
PAGE 

cslocs SEGMENT 'CODE* 

ASSUME CS:cslocs 

SUBTTL LOCSTR - EXECUTABLE CODE 
PAGE 

PUBLIC locstr 
locstr PROC FAR 

PUSH BP 

MOV BP.SP 

PUSH DS 

PUSH ES 

; Handle parameters from calling program 
LES BX,DWORD PTR [BP+14] 

MOV CX.ES:[BX] 

; Check positive request, 
push cx 

cmp cx,0 

Jle outbounds 

LES DX,DWORD PTR [BP+10] 

mov bx.dx 

scanend: 


(continued) 
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mov 

cmp 

Je 

cmp 

J« 

Inc 

loop 

; The request 
pop 
LOS 
OEC 
push 


o I,es:[bxl 
a I , 0 

outbounds 
al ,6 

outbounds 

bx 

scanend 
Is legitimate, 
cx 

BX,DWORD PTR [BP+6] 

CX 

cx 


ADD DX.CX 

; Determine the length of the destinotl 
xor si,si 

mov di.dx 

scanendest: 

mov a I.es:[dI] 

Inc si 

Inc di 

cmp a 1,0 

Jz end_dest 

cmp a 1,6 

Jnz scanendest 

end_dest: 


on 


string. 


mov cx,si 

push cx 

; Determine the length of the source strina 
xor si,si 

mov dl,bx 

scanensour: 

mov oI,ds:[d1] 

Inc si 

inc di 

cmp a 1,0 

Jz end_8our 

cmp a 1,6 

jnz scanensour 

end_sour: 

xchg bx,s i 

push si 

; Locate source string in destination string, 
scandest: 

mov dl,dx 

pop si 

push si 

xor ah,ah 

mov a I,ds:[sI] 

c I d 


repnz scasb 

jcxz failure 

: F ' rst m«u r ° Ct ^ °' 80Urc « is f ound in destination, check the rest, 
mov ax,a I 

dec di 

push cx 

mov cx,bx 

repz cmpsb 

jcxz success 

; No complete match, proceed search in destination strina 
pop cx y 

jmp scandest 

; The index for the request was out of bounds 

outbounds: 


pop 

xor 

jmp 

; No match was 
failure: 


cx 

ax. ax 
ex 11 

found, return zero. 


pop si 

pop cx 

pop cx 

xor ax,ax 

jmp exit 

; A complete match was found, return 
success: 


location of first character. 
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pop 

cx 


pop 

s i 


pop 

ax 


sub 

ax,cx 


pop 

cx 


add 

o 

X 

o 

X 

; Everything 

done excc 

exit: 


POP 

ES 


POP 

DS 


MOV 

SP, BP 


POP 

BP 


RET 

0Ch 

locstr 

ENDP 


cs 1 ocs 

ENDS 


END 

resstr, 

.asm 



"Structural Analysis," by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE RESSTR - SUBROUTINE TO RESET A STRING TO FORTRAN STANDARDS 
PAGE ,132 

; (C) Copyright Microstress Corporation 1984, 1985 
COMMENT * 

RESSTR is a routine designed to be called from FORTRAN as a subroutine 
to reset a string to FORTRAN standards by removing end-of-string marks 
and filling the string with blanks. 

Mode of use: 

cal I RESSTR (string) 

where 

string ■ name of the string (variable of type CHARACTER) to be 
reset. 


♦ 


SUBTTL FORMAL DECLARATIONS 
PAGE 

csress SEGMENT 'CODE* 

ASSUME CS:csress 

SUBTTL RESSTR - EXECUTABLE CODE 
PAGE 

PUBLIC RESSTR 
RESSTR PROC FAR 

PUSH BP 
MOV BP,SP 
PUSH ds 

LDS BX,DWORD PTR [BP+6] 
mov ah,32 

; Scan for either end-of-string mark, 
scanend: 

mov a I,[bx] 
cmp al,0 
jz physical 
cmp a I,6 
Jz logical 
Inc bx 
jmp scanend 

; Fill with blanks between logical and physical marks, 
logical: 

MOV [BX],ah 
inc bx 
mov a I,[bx] 

( continued ) 
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cmp a 1,0 
jnz logical 

; Remove the physical end of string mark 
physical: 

MOV [BX],ah 

; Exit 

POP ds 
MOV SP.BP 
POP BP 
RET 4 

RESSTR ENDP 
csress ENDS 

END 


defdrv.asm 

"Structural Analysis." by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE DEFDRV - SUBROUTINE TO GET OR SET 

THE DEFAULT DISK DRIVE 

PAGE .132 

; (C) Copyright Microst ress 

Corporation 1984, 1985, 1986 

COMMENT * 

Mode of use: 

call DEFDRV (oper.unit) 
where y 

oper - Integer to specify get (-0) or set (-1). 

unit « integer for drive number (0»A,1»B,...). 

SUBTTL FORMAL DECLARATIONS 

PAGE 

csdefd SEGMENT ’CODE’ 

ASSUME CS:csdefd 

SUBTTL DEFDRV - EXECUTABLE CODE 

PAGE 

PUBLIC DEFDRV 

DEFDRV PROC FAR 

PUSH BP 

MOV BP.SP 

push ds 

MOV BX,[BPl+10 
MOV ax,[BX] 

cmp ax,0 

Jnz set 

MOV ah,19h 

Int 21h 

mov bx,[bp]+6 

xor oh,ah 

mov [bxj.ax 

Jmp exit 

set: 

mov bx,[bpl+6 

mov dx,[bx] 

mov ah.OEh 

int 21h 

exit: 

pop ds 

MOV SP,BP 

POP BP 

RET 8 
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DEFDRV endp 
csdefd ENDS 
END 


dskfre.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorri. July, page 199. 


TITLE DSKFRE - SUBROUTINE TO GET THE DISK FREE SPACE AVAILABLE. 

PAGE ,132 

; (C) Copyright Microstress Corporation 1985, 1986 
COMMENT * 

DSKFRE is a routine designed to be called from FORTRAN as a subroutine 
to determine the available disk free space. 


Mode of use: 
where 

drive 

nscl < 

nfcl < 
ntcl ■ 
nbys ' 


♦ 


call DSKFRE (drive,nscl,nfcl,ntcl,nbys) 

« integer variable containing the drive number (0=default, 
1-A, etc...) 

integer variable containing the number of sectors per 
cluster or an error flag (=FFFFh). 

integer variable containing the number of free clusters. 
Integer variable containing the total number of clusters, 
integer variable containing the number of bytes per 
sector. 


SUBTTL FORMAL DECLARATIONS 
PAGE 


csdskf SEGMENT ’CODE* 

ASSUME CS:csdskf 

SUBTTL DSKFRE - EXECUTABLE CODE 
PAGE 

PUBLIC DSKFRE 
DSKFRE PROC FAR 

PUSH BP 
MOV BP,SP 
PUSH DS 

; Get the drive number. 

LDS BX,DWORD PTR [BP+22] 

MOV dx,[bx] 

; Call the system function, 
mov ah,36h 
Int 21h 

; Handle parameters from calling program 
cmp ax,0FFFFh 
je exit 

LDS si,DWORD PTR [BP+6] 

MOV [si],cx 

LDS si,DWORD PTR [BP+10] 

MOV [si],dx 

LDS si,DWORD PTR [BP+14] 

MOV [si],bx 

; Everything done except housekeeping, 
exit: 

LDS si,DWORD PTR [BP+18] 

MOV [si],ax 
POP DS 
MOV SP.BP 
POP BP 
RET 14H 


( continued ) 
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DSKFRE ENDP 
csdskf ENOS 

END 


sizfic.asm 

"Structural Analysis," by Robert W. Johnson and Fernando 
G. Loygorrl. July, page 199. 


TITLE SIZFIL - FUNCTION TO DETERMINE FILE SIZE 
PAGE ,132 

; (C) Copyright Microstress Corporation 1985, 1986 


COMMENT * 

SIZFIL is a routine designed to be called from FORTRAN as a function 
to return the size in bytes of the file specified by the input. 


Mode of use: 
where 

size * * 
fI name 


* 


size - SIZFIL (flname) 

4-byte integer returned with th e file size. 

* name of the file (variable of type CHARACTER) whose 
size is requested. 


SUBTTL FORMAL DECLARATIONS 
PAGE 

cssizf SEGMENT ’CODE’ 

ASSUME CS:cssizf 

SUBTTL SIZFIL - EXECUTABLE CODE 
PAGE 

PUBLIC SIZFIL 
SIZFIL PROC FAR 

PUSH BP 
MOV BP.SP 
PUSH ds 

LDS DX,DWORD PTR [BP+6] 

; Find first (and only) matching file 
xor cx,cx 
mov ah,4Eh 
int 21h 

; Get the current Disk Transfer Address 
mov ah,2Fh 
int 21h 
add bx,26 
mov ax,es:[bxl 
mov dx,es:[bx]+2 

; Exit 

POP ds 
MOV SP,BP 
POP BP 
RET 4 

SIZFIL ENDP 
cssizf ENDS 
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I isptest.doc 

"BYSO Lisp and Waltz Lisp,” by William Wong. July, Page 293 

"BYSO Lisp Benchmark 1-4-86 WGW" 

"Test Loop" 

(defun loop-test (fn limit) 



(fn) ) ) 

(defun dummy ()) 

"CONS Test" 

(setq cons-a nil) 

(defun cons-test () (cons cons-a cons-a)) 

"Integer Addition Test" 

(setq add-a 1 add-b 2) 

(defun add-test () (+ add-a add-b)) 

"Integer Multiplication Test" 

(setq multiply-a 1 multiply-b 2) 

(defun mu 11iply-test () (* multiply-a multiply-b)) 

"Assignment Test" 

(setq assign-a '(1 2 3)) 

(defun assign-test () (setq assign-a assign-a)) 

"List Indexing Test" 

(setq list-index-list '()) 

(do m 1 (+ II))) 

((« i 128)) 


(setq Iist-index-l1st (cons i list-index-list)) ) 

(defun list-index () (nth 120 list-index-list)) 

"Vector Index Test" 

(setq vector-test-array (array 'sexpr 128)) 

(defun vector-index () (aref vector-test-array 120)) 

"String Index Test" 

(setq string-test-array (array 'char 128)) 

(defun string-index () (aref string-test-array 120)) 

"Write test creates a new file and writes 64 kbytes to it." 


[continued) 
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( defun write-test () 

( do-write-test ( open *b:test ) 

512 

( array ’char 128 ) 

) 

) 


( defun do-write-test ( file records buffer ) 

( do 0 

(( zerop ( setq records ( - records 1 ))) ( 
( prInc buffer file ) 

) ) 

; Waltz Lisp Benchmark 1-4-86 WGW 

; Test Loop 

(def loop-test (lambda (fn limit) 

(do ( l 1 ( ♦ I 1 ))) 

((equal t limit)) 

(fn) ) )) 

(def dummy (lambda ())) 


; CONS Test 
(setq cons-a nil) 

(def cons-test (lambda () (cons cons-a cons-a))) 


; Integer Addition Test 

(setq add-a 1) 

(setq add-b 2) 

(def add-test (lambda () (+ add-a add-b))) 


; Integer Multiplication Test 

(setq multiply-a 1 ) 

(setq multlply-b 2) 

(def multiply-test (lambda () (* multiply-a multlply-b))) 


; Assignment Test 
(setq assign-a ’(1 2 3)) 

(def assign-test (lambda () (setq assign-a assign-a))) 


; List Indexing Test 

(setq list-index-list ’()) 

(do ((i 0 (+ l 1))) 

((equal i 128)) 

(setq list-index-list (cons i Iist-lndex-Iist)) ) 
(def list-index (lambda () (nth 120 list-index-list))) 


; Vector Index Test (Arrays Not Supported) 


; String Index Test 

(setq string-test-array MM ) 


close file )) 
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(do «i 0 (+ I 1))) 

((equal I 128)) 

(setq string-test-array (cat "I” string-test-array)) ) 

(def string-index (lambda () (substring string-test-array 120 120))) 

; Write test creates a new file and writes 64 kbytes to it. 

(def write-test (lambda () 

( do-wrlte-test ( outflle "b:test H ) 

512 

string-test-array ) )) 

(def do-write-test (lambda (file records buffer) 

( do () 

! ( zerop ( setq records ( - records 1 ))) ( close file )) 
princ buffer file ) ) )) 

;; Golden Common Lisp Benchmark 1-4-86 WGW 

;; Test Loop 

(defun loop-test (fn limit) 

(do (( i 1 ( + i 1 ))) 
f(- I limit)) 

(apply fn niI) ) ) 

(defun dummy () ) 

;; CONS Test 
(setq cons-a nil) 

(defun cons-test () (cons cons-a cons-a)) 

;; Integer Addition Test 
(setq add-a 1 add-b 2) 

(defun add-test () (+ add-a add-b)) 

;; Integer Multiplication Test 
(setq multlply-a 1 multlply-b 2) 

(defun multiply-test () (* multlply-a multiply-b)) 

;; Floating Point Addition Test 
(setq fp-add-a 1.2 fp-add-b 234324.3) 

(defun fp-add-test () (+ fp-add-a fp-add-b)) 

;; Floating Point Multiplication Test 

(setq fp-multiply-a 1.2 fp-muItIply-b 234324.3) 

(defun fp-muItIply-test () (* fp-multiply-a fp-muItipIy-b)) 

;; Assignment Test 
(setq assign-a '(1 2 3)) 

(defun assign-test () (setq assign-a assign-a)) 


(continued) 
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;; List Indexing Test 

(setq I 1st—Index—Iist ’()) 

(do U\ 1 (+ I 1))) 

(- i 128)) 

(setq list-index-list (cons I Iist-index-Iist)) ) 
(defun list-index () (nth 120 list-index-list)) 


;; Vector Index Test 

(setq vector-test-array (make-array 128 :ini11 al-eIement nil)) 
(defun vector-index () (aref vector-test-array 120)) 


;; String Index Test 
(setq string-test-array 

(make-array 128 :eIement-type ’string-char :initial-eIement 32)) 
(defun string-index () (aref string-test-array 120)) 


"Write test creates a new file and writes 64 kbytes to it." 


(defun write-test () 

(do-wrlte-test (open "b:test" idirectlon *:output) 

512 

(make-array 128 :eIement-type ’string-char) 


( defun do-write-test ( file records buffer ) 

(do () 

(( zerop ( setq records ( - records 1 ))) ( close file )) 
( prInc buffer file ) 


pcrack.bas 

"Stress Analysis," by D. Lee Petersen and Steven L. 
Crocuh. July, page 219. 


1000 REM - 

1010 REM PROGRAM PCRACK.BAS IN MICROSOFT BASIC 

1020 REM - 

1030 REM PROGRAM USAGE NOTES 

1040 REM (1) USE CONSISTENT PHYSICAL UNITS 

1050 REM (2) NUMBER OF ELEMENTS <= 30 

1060 REM - 

1070 DEFINT I-N 

1080 OPTION BASE 1 

1090 DIM A(30,30),DY(30) 

1100 REM-READ BASIC MODEL PARAMETERS 

1110 INPUT "CRACK PRESSURE, CRACK LENGTH, NUMBER OF ELEMENTS";P.CL,N 
1120 W«CL/(2!*N) 

1130 INPUT "MATERIAL PROPERTIES - G,PR";G,PR 

1140 REM-SET CONSTANTS 

1150 PI-3.14159 

1160 CON—G/(PI*W*(1!-PR)) 

1170 REM - GAUSS-SEIDEL ITERATION PARAMETERS 

1180 TOL- .00001 
1190 ITMAX-2*N 
1200 OMEGA-1.3 

1210 REM-INITIALIZE DY AND COMPUTE A MATRIX 

1220 FOR 1-1 TO N 
1230 DY(I)*0! 

1240 FOR J-1 TO N 
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r 1250 A(I.J)-C0N/(4!*(J-I)"2 - II) 

1260 NEXT J 

1270 NEXT I 

1280 REM - SOLVE EQUATIONS BY GAUSS-SEIDEL ITERATION 

1290 FOR NUM - 1 TO ITMAX 
1300 ERRMAX-0! 

1310 FOR 1-1 TO N 

1320 TEMP-0! 

1330 FOR J-1 TO N 

1340 TEMP-TEMP+A(I,J)*DY(J) 

1350 NEXT J 

1360 TEMP«(P-TEMP)/A(I,I) 

1370 DY(I)«OY(I)+OMEGA*TEMP 

1380 ERRI-ABS(TEMP) 

1390 IF ERRI > ERRMAX THEN ERRMAX-ERRI 

1400 NEXT I 

1410 IF ERRMAX <- TOL THEN GOTO 1460 

1420 PRINT USING"ITERATION, MAXIMUM ITERATE ## #.######";NUM;ERRMAX 

1430 NEXT NUM 

1440 PRINT "ITERATION PROCESS DID NOT CONVERGE AFTER";ITMAX;" ITERATIONS!" 
1450 STOP 

1460 REM-PRINT RESULTS 

1470 PRINT "ELEM CRACK OPENING CRACK OPENING COMPUTED STRESS" 

1480 PRINT " (NUMERICAL) (ANALYTICAL)" 

1490 DELB-CL/N 
1500 X—(CL+DELB)/2! 

1510 B-CL/2 

1520 CON-2!*(1!-PR)*P*B/G 
1530 FOR I - 1 TO N 
1540 SIGYY-0! 

1550 FOR J - 1 TO N 

1560 SIGYY-SIGYY+A(I,J)*DY(J) 

1570 NEXT J 

1580 X-X+DELB 

1590 DD-CON*SQR(1!-(X~2/8~2)) 

1600 PRINT USING" ## ##•#### ##-#### ######.#";I;OY(I);DD;SIGYY 

1610 NEXT I 
1620 END 


msp.pas 

"A Material Selection Program," by Brother Tom Sawyer and 
Michael Pecht. July, page 235. 


PROGRAM MSP; 

{ Material selection program { 

\ Major sections: Utilities, Fllework, Newbase, Addtobase and Searchbase} 
jBTS eV 1 ^/® 5 major file handling rev. 9/15/85 tuning etc. 1/20/86 } 

|$B-{ (*compiler directive for direct read*) 

CONST 

maxattributes » 31; 
maxquaIifiers ■ 10; 
maxalablen * 20; 
maxqlablen ■ 10; 
max items * 300; 
maxroot * 6; 

TYPE 

attrnum * 0..maxattr1butes; 

Itemnum ■ 0..maxltems; 
qualnum ■ 0..maxquaIifiers; 
flag - -1..1; 

attrlab - STRING[maxalab Ienl; 

quallab ■ STRING[maxqIabIenl; 

itemlab - STRING[maxaIabIenJ; 

qualifiers * ARRAY[quaInum] OF quallab; 

attrdata - (NUL.D1 ,D2,D3.D4,D5.D6,D7,D8,D9,D10); 

Itemdata - ARRAY [attrnum] OF attrdata; 
attrrec ■ RECORD 
atnum : attrnum; 
atname : attrlab; 

( continued ) 
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qlnum : qualnum; 
qua Is : qua I 1fiers 
END; 

itemrec - RECORD 
fid ; CHAR; 
inum ; INTEGER; 
iname : itemlab; 
idata : itemdata 
END; 

rankitemrec ■ RECORD 
rating : INTEGER; 

Item ; Itemrec 
END; 

rootname = STRINGfmaxroot]; 
finamrec * RECORD 
id : CHAR; 
rtnam: rootname; 
name : itemlab 
END; 

Trackrec * RECORD 
nofiterns : INTEGER; 
atnum ; attrnum; 
atrbute ; attrdata; 
selection ; CHAR; 
atname ; attrlab; 
qua I name : qua I Iab 
END; 


markarray * ARRAYTattrnum 
attrtable * ARRAY |attrnum 
Itemtable ■ ARRAY | itemnum 
ranktable * ARRAY[itemnum 
afile ■ FILE OF attrrec; 
if i le - FILE OF itemrec; 
Nfile * FILE OF Finamrec; 
Tfile - FILE OF Trackrec; 
strl ® string[80]; 


OF BOOLEAN; 

OF attrrec; 

OF Itemrec; 

OF rankitemrec; 


VAR 

exit : BOOLEAN; 
ch:CHAR; 

firoot : rootname; 
finame ; itemlab; 
volid : STRING[2]; 

{Utilities Procedures} 

PROCEDURE Center(astringistri); {center a string on the screen} 

indent : INTEGER; 

BEGIN 

indent :* (80 - LENGTH(astring)) DIV 2; 

WRITELN(•*:indent,astrIng) 

END; 

FUNCTION Spa(indent:INTEGER);CHAR; {insert spaces in a write(ln) statement} 
BEGIN 

indent :« indent - 1; 

WRITE(*':indent); 

Spa :« * • 

END; 


PROCEDURE Rdupcase(VAR ch:CHAR); {read and capitalize a character} 
BEGIN 

READ(ch); 

IF ch IN ['a *..* z * 1 THEN 
ch :« CHR(ORD(ch) - 32) 

END; 


PROCEDURE Fixa (istr:strI;VAR a Iab:attrIab); 

VAR {Change a string into an attribute label} 

J:INTEGER; 5 

BEGIN 

a I ab :■ M ; 

FOR J := 1 TO maxalablen DO 
a lab CONCAT(aIab.• ’); 
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FOR J :* 
a Iab[J 
END; {FIxa 


1 TO LENGTH(lstr) DO 
:* Istr[J] ; 


{File handling section} 


PROCEDURE Getfiname(VAR firoot;rootname; VAR finame:itemIab; 

VAR choice:CHAR; VAR exit:BOOLEAN); 
Create and check new file names, show available data bases} 
ifiroot is the root name of the data base files} 
exit Is true if user chooses main menu or files don’t exist} 
•choice may be changed if no AT or IM files are present} 

VAR * 

chx : CHAR; 

nfrec : finamrec; {global to Proc. Getfiname} 
tempstr ; strl; 
nffile : Nfile; 


PROCEDURE Showbases(VAR chx:CHAR); 

BEGIN 

GOTOXYf1,10); 

Center(’List of current data base names:'); 
WRITELN; 

RESET(nfflie); 

WHILE NOT (EOF(nffile)) DO 
BEGIN 

READ(nff1le,nfrec); 

WITH nfrec DO 
IF id > THEN 
BEGIN 

WRITELN(Spa(25),id,': ’.name); 
chx :■ id 
END 

END jwhile} 

END; jShowbases} 


PROCEDURE Addtosearch(VAR fI root:rootname; VAR finame:Itemlab; 

VAR exit:BOOLEAN; chx:CHAR); 

VAR 

found : BOOLEAN; 
ch : CHAR; 

BEGIN 

found :■ FALSE; 

REPEAT 

REPEAT 

GOTOXY(1,21); 

Center('PI ease type in the LETTER of your choice.'); 

Center('Press RETURN to EXIT.’); 

Rdupcase(ch) 

UNTIL (ch IN ['A'..CHX]) OR (eoln); 

IF eoln THEN 
exit TRUE 
ELSE 
BEGIN 

RESET(nffIle); 

WHILE NOT (EOF(nffile)) DO 
BEGIN 

READ(nffiIe,nfrec); 

WITH nfrec DO 
IF id - ch THEN 
BEGIN 

flroot rtnam; 
flname :■ name; 
found :- TRUE 
END {if} 

END; {while} 

IF NOT found THEN 

Center('There is no file with that letter*); 

END {else} 

UNTIL (found) OR (exit) 

END; {Addtosearch} 

PROCEDURE Checkatim(firoot;rootname; VAR choice:CHAR; VAR exit:BOOLEAN); 
{for choices B and C: check to see if attribute/item files have data} 


[continued) 
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VAR 

ch : CHAR; 
fnam : strl; 
atrec : Attrrec; 

Itrec : Itemrec; 
atf I Ie: AfI Ie; 
itfile: Ifila; 

BEGIN 

fnam CONCAT(voI id, f I root,’AT.DTA’); 

ASSIGN(atfIle,fnam); 

RESET(atflie); 

READ(atf Me,atrec); 

IF atrec.atnum - 0 THEN {no attributes exist} 

BEGIN 

clrscr; G0T0XY(1,5); 

Center(*Sorry but no attributes have been created for that data base.*) 
WRITELN(Spa(8),*A) Go to the section that creates the attribute table. 
WRITELN(Spa(8),’B) Exit to the Main Menu.\CHR( 10)) ; 

Center('Type In the LETTER of your choice’); 

REPEAT Rdupcase(ch) UNTIL ch IN [’A’.’B’l; 

IF ch » ’A’ THEN choice ’A’ 

ELSE exit TRUE 
END; 

CLOSE(atfiIe); 

IF (choice * ’C’) AND (NOT exit) THEN 
BEGIN 

fnam C0NCAT(voI id,fI root,•IM.DTA*); 

ASSIGN(itflI e,fnam); 

RESET(ItfiIe); 

READ(!tf Me, Itrec); 

IF Itrec.Inum ■ 0 THEN {there is no data} 

BEGIN 

clrscr; G0T0XY(1,5); 

Center(’Sorry but there is no data in that data base.’); 
WRITELN(Spaf8),’A) Go to the ADD DATA section.*); 

WRITELN(Spa(8),’B) Exit to the Main Menu.’,CHR(10)); 

Center(*Type in the LETTER of your choice’); 

REPEAT Rdupcase(ch) UNTIL ch IN [’A’.’B’l; 

IF ch - *A* THEN choice :« *B* 

ELSE exit TRUE 
END; 

CLOSE(itf Me) 

END {if choice - C} 

END; {Checkatim} 

PROCEDURE NewatIm(fI root;rootname;finame:11emIab;ch:CHAR); 

{Create Attribute (AT) and Item (IM) files and initialize first record} 

VAR 

tempstr: stri; 
count ; INTEGER; 
atrec:attrrec; 
itrec:itemrec; 
atfile: Afile; 

Itflle:Ifile; 

BEGIN 

WITH atrec DO 
BEGIN 

atnum :■ 0; atname :*= finame; qlnum :=* 0; 

FOR count :** 0 to maxqua I I f iers DO 
quals[count] :« **; 

END; 

WITH Itrec DO 
BEGIN 

fid :« ch; iname :* finame; inum := 0; 

FOR count :* 0 to maxattributes DO 
idata[count] :* NUL {lowest value} 

END; 

tempstr :« CONCAT(voI id,f!root,’AT.DTA’); 

ASSIGN(atfile,tempstr); 

REWRITE(atfile); 

WRITE(atfile.atrec); 

CLOSE(atfile); 

tempstr := CONCAT(voI id,firootIM.DTA’); 

ASSIGN(itfile,tempstr); 

REWRITE(ltfile); 

WRITE(itfile,itrec); 
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CLOSE(11f tI*); 

ENO; {NewatIm| 

PROCEDURE NewfI Ie(VAR fI root:rootnam#; VAR f(name:itemlab; VAR exit:BOOLEAN); 
|Get and verify new data base name} 

{Store If not a duplicate else get another name or exit} 

VAR * 

okay,found : BOOLEAN; 
chx : CHAR; 

I en,temp Int : INTEGER; 

Iabstr,tempstr,fnam : strl; 
atf11e : AfI Ie; 

BEGIN 

gotoxy(1,21); 

Center('PIease type in the name of the new data base.*); 

Center('Press RETURN for main menu.'); 
exit FALSE; 

REPEAT 

okay :■ TRUE; 

WRITELN; 

WRITE(Spa(20),'*=> '); READLN(con,labstr); 
len := LENGTH(Iabstr;; 

IF len « 0 THEN 

exit :« TRUE (* EXIT *) 

ELSE IF len > maxalablen THEN 
BEGIN 

okay :« FALSE; 

WRITELN(Spa(20),*A name may not exceed ’.maxalablen,' characters.') 

END 7 

ELSE 

BEGIN {Create a file rootname (first 6 non-space characters)} 
tempstr :■ labstr; 
tempint :■ POS(’ '.tempstr); 

WHILE tempint <> 0 DO 
BEGIN 

DELETE(tempstr,tempint,1); 
tempint :-POS(* ',tempstr) 

END; 

tempint :* len - maxroot; 

IF tempint > 0 THEN 
DELETE(tempstr.maxroot+1.tempint); 
firoot :■ tempstr; 

Fixa(Iabstr,finame); 

tempstr :« CONCAT(voIid,fI root,'AT.DTA’); 

ASSIGN(atflle,tempstr); 

{$ 1 -} 

RESET(atflie); 

IF IORESULT ■ 0 THEN {duplicate name} 

BEGIN 

CLOSE(atfile); 
c I rscr; 
gotoxyh ,5); 

Center('Sorry, but the first six characters of two data base names’)* 
Center('may not be identical.'); 

Showbases(chx); 
gotoxyf1,21); 

Centerf’Type in another name please.'); 

Center(’(Press RETURN for main menu.)’); 

OKAY FALSE 
END 

ELSE {add name to list of file names} 

BEGIN 

RESET(nfflie); 

tempint :■ 0; found := FALSE; 

WHILE (NOT EOF(nfflle)) AND (NOT found) DO 
BEGIN 

READ(nffIle.nfrec); 

IF nfrec.id - ’«’ THEN found TRUE; 
tempint tempint + 1 
END; 

IF found THEN tempint :■ tempint - 1; 

WITH nfrec DO 
BEGIN 

id :■ CHR(tempint + 65); 


( continued ) 
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rtnam :* firoot; 
name flname 
END; 

SEEK(nffile,templnt); 

WRITEfnffIle,nfrec); 

NewatIm(fI root,flname.nfrec.Id) 

END {else add name} 

l$I+» 

END {else create rootname} 

UNTIL okay - TRUE 
END; {Newflle} 

PROCEDURE Removef11e(fI root:rootname; flname:itemlab; 

VAR exlt:BOOLEAN; chx:CHAR); 

{Removes a data base (IM and AT files) and replaces 

ft I aID In FInames.DTA with the ’@* character.} 

VAR 

templnt : INTEGER; 
found ; BOOLEAN; 
ans : strl; 
atf11e:AffIe; 

ItfI Ie:If Ile; 

BEGIN 

Center(*You are about to permanently remove the data base'); 
WRITELN(Spa(20),flname); 

Center(*You must type the word YES (In capitals) to do this.'); 
WRITE(’-»-> ’); READLN(ans); 

IF ans <> ’YES* THEN exit TRUE 

ELSE 

BEGIN 

ans :« CONCAT(voI Id,fI root,’AT.DTA’); 

ASSIGN(atfIle.ans); 

ERASE(atfIle); 

ans :« CONCAT(voIld.fI root,•IM.DTA’); 

ASSIGN(11fI I e,ans); 

ERASEfitfIle); 

RESET(nffIle); 

templnt :• 0; found :■ FALSE; 

WHILE (NOT EOF(nfflle)) AND (NOT found) DO 
BEGIN 

READ(nffIle.nfrec); 

IF nfrec.rtnam ■ firoot THEN found :* TRUE; 
templnt :* templnt + 1 
END; 

IF found THEN templnt :* templnt - 1; 

WITH nfrec DO 
BEGIN 
Id :« 

rtnam :* •*; 
name ” 

END; 

SEEK(nffIle f tempint); 

WRITE(nffIle.nfrec); 
exit TRUE 
END 

END; {Removeflie} 

PROCEDURE ShowtItIe(choIce:CHAR); 

BEGIN 

clrscr; G0T0XY(1,2); 

CASE choice OF 

’A*: Center(’CREATE A NEW DATA BASE’); 

’B’: Center(’ADD DATA’); 

’C’: Center(’SEARCH THE DATA BASE*); 

*D*: Center(’REMOVE A DATA BASE*) 

END {case} 

END; {ShowtItIe} 

BEGIN {GetfI name} 
clrscr; 

exit :* FALSE; 

j$H 

tempstr :* CONCAT(volId, ’FINAMES.DTA’); 

ASSIGN(nffI Ie.tempstr); 

RESET(nffile); 

IF (IORESULT <> 0) AND (choice » *A’) THEN {create the name file} 
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BEGIN 

REWRITE(nffiI«); 

WITH nfrec DO {initialize finame record 0} 

BEGIN 

id :» ’*•; 
rtnam :* M ; 
name :■ •• 

END; 

WRITE(nffile,nfrec) 

END 

ELSE IF IORESULT <> 0 THEN {no data bases available} 

BEGIN * 

Center('There are no data bases available’); 

Center(’You will have to create one before doing any further work ')• 
exit TRUE 
END 

ELSE; {dummy option} 

i$I+} 

IF NOT exit THEN 
BEGIN 

Showtitle(choice); 

Showbases(chx); 

CASE choice OF 

*A*: Newfile(firoot,finame,exit); 

’B’..’D’: Addtosearch(firoot.finame,exit,chx) 

END; {case} 

IF NOT exit THEN 
CASE choice OF 

*B*,*C*: Checkatim(firoot.choice,exit); 

'D* : Removefile(firoot,finame,exit,chx) 

END {case} 

END; 

CLOSE(nffile) 

END; {Getflname} 

PROCEDURE Searchbase(firoot:rootname; finame;itern Iab); {search data base} 
VAR 

exit : BOOLEAN; 
fnam ; strI; 
atable ; attrtable; 

Tree : Trackrec; 

Trfile : Tfile; 

PROCEDURE Wtandrank(VAR It:RanktabIe;atn:attrnum;atrrattrdata; 

qIn:quaInum ;wt;INTEGER; wtit:BOOLEAN); 

VAR 

J.last.baseval.atrval ; INTEGER; 

PROCEDURE Rank I 1st(VAR ItrRanktable; Iast;INTEGER); 

VAR {selection sort by decreasing rating} 

J.K.hdx : INTEGER; 
switch : BOOLEAN; 
high : rankitemrec; 

BEGIN 

FOR J 1 TO last-1 DO 
BEGIN 

switch :« FALSE; 

high It[J]; hdx :■ J; 

FOR K J + 1 TO last DO 

IF It[K].rating > high.rating THEN 
BEGIN 

switch :* TRUE; 
high :« It[K]; 
hdx :« K 
END; {If} 

IF switch THEN {must switch places} 

BEGIN 

It [hdx] :« It[J]; 

It[j] ;■ high 

END 

END {for J} 

END; {Ranklist} 

BEGIN {Wtandrank} 
baseval :■ ORD(atr); 


[continued] 
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last :■ It[0].Item.Inum; {# of items in array} 

FOR J 1 TO last DO 
BEGIN 

atrval :■ ORD(It[J].1 tern.Idata[atn]); 

IF (wtit) AND (atrval > 0) THEN 

11[J J•rating :■ It[J].rating + ROUND(wt*ABS(baseval-atrvaI)/qIn) 

END; 

IF wtit THEN 
Rank!Ist(It•last) 

END; {Wtandrank} 

PROCEDURE Searchfor(VAR It:ranktabIe; atnrattrnum; atr:attrdata; 

fnam:stri; seI code:CHAR; VAR Zflag:flag); 

{Get data from file or from ranktable. It[0] used to pass values to output} 
VAR 

memsrch : BOOLEAN; 

J.cnt.last : INTEGER; 
itrec : itemrec; 
tempatr : attrdata; 
itf11e:Ifile; 

PROCEDURE Checkrec(VAR cnt:INTEGER); 

I look for data in It or on disk} 

changes It and uses seI code,tempatr,atr.memsrch, and J} 

VAR 

match : BOOLEAN; 

BEGIN 

match :■ FALSE; 

CASE selcode OF 

*A* ; IF tempatr <- atr THEN match :« TRUE; 

*B* : IF tempatr * atr THEN match :« TRUE; 

*C' : IF tempatr >« atr THEN match TRUE 

END; {case} 

IF (memsrch) AND (tempatr ■ NUL) THEN {Include "no data" items} 
match TRUE; 

IF match THEN 
BEGIN 

cnt :* cnt ♦ 1; 

IF memsrch THEN {data is in It} 

It[cnt] :« It[J] 

ELSE {data is on disk} 

BEGIN 

ItTcntl.ratIng :* 0; {Initialize rating} 

ItfcntJ.item :* Itrec 
END 

END {if match} 

END; {Checkrec} 

BEGIN {Searchfor} 
cnt :« 0; 

Zflag :« 0; {assume no data is present} 

last :■ It[0].I tern.Inum; 

IF last = 0 THEN {search disk file} 

BEGIN 

memsrch :« FALSE; 

ASSIGN(itfile.fnam); 

RESET(Itfile); 

READfitfile,Itrec); 

It[0].I tern.I name :» itrec.iname; {data base name} 

WHILE NOT EOF(itfIle) DO 
BEGIN 

READ(!tfIle.itrec); 
tempatr :■ Itrec.idata[atn]; 

Checkrec(cnt); 

END; 

CLOSE(itfiIe); 

IF cnt * 0 THEN Zflag :* -1 {No items found in data base} 

END {Iast=0} 

ELSE {search array It} 

BEGIN 

memsrch :■ TRUE; 

FOR J :« 1 TO last DO 
BEGIN 

tempatr :» IT[J].1 tern.idata[atn]; 

Checkrec(cnt) 

END; 

IF cnt » 0 THEN Zflag 1 {No Items in It fit the new constraint} 
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END; {else} 

lt[0].Item.ldata[0] := atr; {desired qualifier value} 

IF Zflag <> 1 THEN {change item count. New list or no items in data base} 

IT[0].itern.inum :» cnt 
END; {Searchfor} 

PROCEDURE Dumpdata(VAR A :attrtab Ie;VAR IT:ranktable;atn:attrnum; 

print;markarray;VAR seI code,I data,dev:CHAR); 

{Output list and rating to console or printer} 

VAR 

devnam : stri; 
ch,If : CHAR; 
outf iIe : text; 

PROCEDURE PAUSE; 

BEGIN 

IF DEVNAM - 'con:* THEN 
BEGIN 

GOTOXY(1,24); 

Center('Press any key to continue.*); 
repeat until keypressed; 
cIrscr 
END 

END; {PAUSE} 

PROCEDURE Outlist; {output list and rating} 

VAR 

j,last.pos,Ioopcount:INTEGER; 

PROCEDURE Heading; 

BEGIN 

GOTOXY(1, 2); 

WRITELNfOutffle,'RANKED LISTING':20,'Number of iterns':20,It[0].itern.inum:4); 
WRITELN(outf!le,'Data Base; ’:18,IT[0].itern.iname,If); 

RESET(Trf1le); 

WRITELN(outfiIe,'Attribute*:16,'Qualifier *:32,'# of Items':13.If); 

WHILE NOT EOF(Trfile) DO 
BEGIN 

READ(TrfI Ie,trec); 

WITH tree DO 
BEGIN 

WRITE(outfI Ie,atname:23); 

CASE selection OF 

'A*: WRITEfoutf1 Ie,' ',A[atnum].qua Is[1],' to *,qual name); 

'B*: WRITE(outfiIe,’ *,'equal to *,qualname); 

'C': WRITE(outf1 Ie,' ',qualname,' to ',A[atnum].qua Is[A[atnuml.qInum]) 
END; {case} 

WRITELN(outfI Ie,nofItems:5) 

END {with} 

END; {while} 

WRITELN(outf1le,If,' NO.','ITEM ':20,'RATING':9,If) 

END; {Heading} 

BEGIN {Outlist} 
c I rscr; 

Heading; 

last :« It[0].I tern.inum; 
loopcount:- 1; 

FOR J ;« 1 TO last DO 
BEGIN 

WRITELN(outfIle,J:3,': ’,IT[J].I tern.iname,IT[J].rating:6); 

IF (J MOD 10 - 0) AND (loopcount <> last) AND (devnam - 'con:') THEN 
BEGIN 
Pause; 

Heading 

END; 

loopcount :« loopcount+1 
END; 

WRITELN(outfI Ie,If, I f) ; 

Pause 

END; {Outlist} 

PROCEDURE Crtdata; { Output the actual data to screen { 

VAR ’ 

J.K.POS,lasta,last I,C : INTEGER; 


( continued) 
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I os to A[0].atnum; 

lost! lt[0].I tern.Inum; 

clrscr; GOTOXY(10.2); 
WRITELN('Dota Base: ’.IT[0].I tern. 
WRITE(Spa(19)); 

C 0; {count for 

FOR K :■ 1 TO lasta DO 
IF PRINT[K] - TRUE THEN 
BEGIN 

WRITE(A[K].atname); 

C C + 1; 

IF C MOD 3 - 0 THEN 
BEGIN 
WRITELN; 

WRITE(Spa(19)) 

END 

END; {If true} 

WRITELN; 

FOR J 1 TO losti DO 


name); 

Iinefeeds} 


BEGIN 

WRITELN(Spa(5),IT[J].ltem.lname); 


C 0; 

WRITE(Spa(13)); 

FOR K :» 1 TO lasto DO 
BEGIN , ,, 

POS:- ORD(IT[J].Item.Idato[K]); 
IF PRINT[K] - TRUE THEN 
BEGIN 

WRITE(A[K].qua Ie[POS]:20); 


C C + 1; 

IF C MOD 3 - 0 THEN 
BEGIN 
WRITELN; 

END {if modi 
END {If true| 

END; {for k| 

WRITELN; 

IF J MOD 3 - 0 THEN 
PAUSE 


END; 

IF last I - 0 THEN 

WRITELN(Spo(15),‘No Items fit this condition.’); 
WRITELN 
END; {Crtdataj 


PROCEDURE Printdata; { Output the actual data to printer} 
VAR 

J.K.POS.lasta.lastl,C ; INTEGER; 

BEGIN 
clrscr; 

WRITELN(OutfIle.If); 
lasta :■* A[0].atnum; 
c :■ 0; 

FOR K 1 to lasta DO 
IF prlnt[K] *= TRUE THEN 
c c + 1; 

IF c > 3 THEN 

WRITEfoutfIle,CHR(15)); {Epson compressed print on} 
WRITELN(outfile.’Data Base: ’:17,IT[0].I tern.iname,If); 
lastl :» IT[0].I tern.inum; 

WRITE(outfIle, ” :20); 

C 0; {count for linefeeds} 

FOR K 1 TO lasta DO 

IF PRINT[K] - TRUE THEN 
BEGIN 

WRITE(outfIle,A[K].atname); 

C :■ C + 1; 

IF C MOD 5 = 0 THEN 
WRITE(outf11e,If,* *:20) 

END; {IF TRUE} 

WRITELN(outfIle); 

FOR J 1 TO lastl DO 

BEGIN 

WRITE(outfIle,If,IT[J].I tern.I name:20); 
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C := 0; 

FOR K :■ 1 TO lasta DO 
BEGIN 


POS:« ORD(IT[J].item.idata[K]); 

IF PRINT[K] - TRUE THEN 
BEGIN 

WRITE(outfile,A[K].quals[POS]:15,* 
C :*= C + 1; 

IF C MOD 5 - 0 THEN 
WRITE(outfIle,If,’':20) 

END |IF TRUE} 

END; {FOR K} 

WRITELN(outf Me) 

END; {for j} 

IF last! « 0 THEN 
WRITELN(outfI I e, ’ No 

WRITELN(outf He, If ,CHR(18)) 

END; {Printdata} 




Items fit this condition.'); 
{EPSON COMPRESSED MODE OFF} 


PROCEDURE Lmenu(VAR I data,devrCHAR); 

VAR ans ; CHAR; 

BEGIN 

GOTOXY(1,22); 

Centerf'Type the LETTER of your choice.'); 

GOTOXYt1,3); 

Center('DISPLAY DATA FOR ITEMS IN RANKED LIST.'); 
REPEAT 

G0T0XY(1,7); 

WRITELN(Spa(18),'A) List values on the screen.'); 
WRITELN($pa(18),'B) List values on the printer.'); 
WRITELN(Spa(18),'C) No data list is desired.'); 
Rdupcase(ans) 

UNTIL ans IN ['A'..'C']; 

IF ans - 'C' THEN 
Idata ;■ 'N' 

ELSE 

Idata 'Y'; 

IF ans - 'B' THEN 
dev :» 'P' 

ELSE 

dev := 'C* 

END; {Lmenu} 


BEGIN {Dumpdata} 

If := CHR(10); {linefeed character} 

WRITELN(If); 

IF dev - 'C' THEN 
DEVNAM 'con:' 

ELSE 

DEVNAM :« '1st:'; 
assign(outf1le,devnam); 

RESET(outfile); 

IF LDATA ■ 'Y' THEN {user wants a listing of the data} 

BEGIN ' 

IF devnam - 'con:' THEN 
Crtdata 
ELSE 

Printdata; 

PAUSE 

END; 

IF LDATA - 'L' THEN {output ranked list and see if user wants to list data} 
BEGIN 
OUTLIST; 

Lmenu(Idata,dev) 

END; 

CLOSE(outfIle) 

END; {Dumpdata} 


PROCEDURE PICKATTR(VAR A:attrtable; fI root:rootname); 
VAR {Main procedure for Searchbase} 

COUNT,WT ; INTEGER; 

ch,chx.se I code,dev,If : CHAR; 

OKAY,SHOW,WTIT : BOOLEAN; 
atn.TEMPatn : attrnum; 
fnam : strI; 
atr : attrdata; 


July 
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ITMATTR : Itemdata; 

Zflog : flag; 

PICKED,PRINT ; markarray; 

IT : ranktable; 

PROCEDURE GETQUAL(J:INTEGER;VAR atr:attrdata;VAR seI code:CHAR); 

K : INTEGER; 

QLN : qualnum; 

CH.CHX : CHAR; 

BEGIN 
clrscr; 
gotoxy(12,5); 

WRITELN('ATTRIBUTE #’,A[J].atnum,*: \ A[J].atname); 

CHX :« *@*; {char that preceeds the letter *A’{ 

FOR K :■ 1 TO A[J].qlnum DO 
BEGIN 

CHX SUCC(CHX); 

WRITELN(Spa(12),CHX:3,*; *,A[j].quals[K]); 

END; L Jy 

REPEAT 

gotoxy(1,22); 

Centeri'Type the LETTER of the qualifier that will be the’); 

Center(’PIVOT (MINIMUM acceptable value) of your search. *); 
Rdupcase(ch) 

UNTIL CH IN [ * A*..CHX]; 

GOTOXY(1,22); 
clreol; WRITELN; 
cl reol; 

QLN :* ORD(CH) - 64; {change letter to qualifier 

atr :■ ITMATTR[QLN]; jqual jjl to actual qualifier valued 

REPEAT 

gotoxyf1,16); 

Center('Range Select Ion:*);WRITELN; 

WRITELNfSpaf10),'A: Include qualifiers from "A" to "',ch,* M *)- 
WRITELN(Spa(10),*B: Choose qualifier ‘".ch,*" only*); 

WRITELN(Spa(10),*C: Include qualifiers from ‘",ch,*" to M, ,chx *"* If) 
Center(*Type the LETTER of your choice.*); 

Rdupcase(ch) 

UNTIL CH IN [*A*..*C*]; 
selcode CH 
END; {GETQUAL} 


PROCEDURE Showattr(VAR Mark:Markarray;VAR chx:CHAR); 

{Mark Is not changed by this proc.J 

VAR 

J,Iast : INTEGER; 

BEGIN 

last :** A[0].atnum; 
cIrscr; 
gotoxyf1,5); 

Center(’CHOOSE ATTRIBUTES’); 

WRITE(If,Spa(8),'CODE ATTRIBUTE’); 

IF last <= 16 THEN WRITELN(lf) 

ELSE 

BEGIN 

GOTOXY(40,7); 

WRITELN(’CODE ATTRIBUTE’,If) 

END; 

CHX ’A’; 

IF last <» 16 THEN 
FOR J 1 TO last DO 
BEGIN 

IF MARK[J] THEN 

WRITELN(Spa(4).’CHOSEN: •,A[J].atname) 

ELSE 

WRITELN(Spa(9l.CHX,’: ’.A[J].atname); 

CHX := SUCC(CHX) 

END 

ELSE 

BEGIN 

FOR J := 1 TO 16 DO 
8EGIN 

IF MARK[J] THEN 

WRITELN(Spa(4).’CHOSEN: ’,A[J].atname) 
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WRITELN(Spa(9),CHX,’: *,A[J].atname); 

CHX :« SUCC(CHX) 

END; 


FOR J :« 17 TO last DO 
BEGIN 

GOT OXY(40,J-8); 

IF MARK[Jl THEN 

WRITELN(’CHOSEN: •,A[J].atname) 

ELSE 

WRITELN(’ *,CHX,’: \ A[J].atname); 

CHX SUCC(CHX) 

END 

END {ELSE! 

END; {SHOWATTR} 


PROCEDURE Getcode(VAR ch,chx:CHAR); 

jchx not changed by this proc} 

BEGIN 

REPEAT 

gotoxyf1 ,22); 

Centerf’Type a LETTER to choose an item.*); 

Center(’Press SPACEBAR when done. ’); 

Rdupcase(ch) 

UNTIL CH IN [’ \’A\.CHX] 

END; {Getcode} 


PROCEDURE Getweight(VAR wt:INTEGER); 
VAR 


ch ; CHAR; 
BEGIN 
REPEAT 


clrscr; 
gotoxyf1,5); 

Center(*SeIect the RELATIVE IMPORTANCE (weight) you wish to assign’); 
CenterC’to this attribute in the overall selection process:*); 
G0T0XY(1,8); 

WRITELN(Spa(22),*A: GREATEST’); 

WRITELN(Spa(22),*B: HIGH’); 

WRITELN(Spa(22),’C: MEDIUM’); 

WRITELN(Spa(22),*D: LOW’); 

WRITELN(Spa(22),*E: LEAST’); 
gotoxyf1,22); 

Center(’Type In the LETTER of your choice.’); 

Rdupcase(ch) 

UNTIL ch IN [’A*..*E*]; 

CASE ch OF 

’A’:WT :- 50; { MULTIPLE OF TEN USED TO PRODUCE WHOLE NUMBER } 

’B*:WT :- 40; | VALUE IN THE RANKING PROCEDURE } 

*C*:WT :» 30; 

’D’:WT :- 20; 

*E’:WT :- 10 
END {case} 

END; jGetweight} 


PROCEDURE SHOWORNO(VAR show:BOOLEAN;numofiterns:INTEGER;zfI:fIag;VAR dev:CHAR); 
VAR 

ans: CHAR; 

PROCEDURE Showmenu(VAR ch:CHAR); 

BEGIN 

GOTOXYf1,22); 

Center(*Type the LETTER of your choice.*); 

REPEAT 

GOTOXY(1,10); 

WRITELN(Spa(18),*A) Print ranked list on screen.’); 

WRITELN(Spa(18),*B) Print ranked list on printer.’); 

WRITELN(Spa(18), *C) No listing desired.’Jf); 

Rdupcase(ch) 

UNTIL ch IN [*A’..’C’] 

END; {Showmenuf 

BEGIN {Showorno} 
clrscr; 
gotoxy(1,5); 

ANS *N*; {ASSUME NO-SHOW DATA} 

IF ZFL - 0 THEN 
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BEGIN 

WRITELN(Spa(19).NUMOFItemS,• Items meet your spec!fIcatIons.',If); 

Center('Choose an option for listing these items.'); 

Showmenu(ans) 

END {IF ZFL - 0 { 

ELSE IF ZFL - -1 THEN 
BEGIN 

Center('The data base has no Items which fit your requIrments.*); 
ans *C' {force a M no show"} 

END 

ELSE 

BEGIN 

Center('There are no Items that fit the new specifications.'); 

WRITELN; 

Center('Choose an option for the PREVIOUS list.’); 

Showmenu(ans) 

END; {ELSE} 

IF ANS - 'C' THEN 
show FALSE 
ELSE 

show :« TRUE; 

IF ans - 'B' THEN 
dev 'P' 

ELSE dev 'C' 

END; {Showorno} 

PROCEDURE SELECTERR(VAR OKAY,WTIT : BOOLEAN); 

VAR 

CH : CHAR; 

BEGIN 

OKAY FALSE; {ASSUME NO REPITITION OF ITEM} 
cIrscr; 
gotoxyh ,5); 

Centeri’That Item has been selected already'); 

GOTOXYC1,8); 

Center('NOTE: If you reselect the attribute:'); 

WRITELNfIf,Spa(18),'1) Only qualifiers that are within the range already' 
WRITELN(Spa(23),'seIected will be used In the data search.'); 

WRITELN(If,Spa(18),'2) The list will retain its original weighting’); 
WRITELN(Spa(23),'for this attribute.’); 
gotoxyf1,21); 

Centerf'Type the LETTER "R" to repeat this Item selection.'); 

Center('Press any other key to make another selection.*); 

READ(CH); 

IF CH IN ['R'.'r'] THEN 
BEGIN 

OKAY :« TRUE; 

WTIT :» FALSE {SAME ATTRIBUTE THEREFORE. DO NOT WEIGHT"TT AGAIN} 

END; 
cIrscr 

END; {SELECTERR} 

PROCEDURE In I tatr; 

{Initialize Itmattr array and create tempfile for tracking selections} 

VAR 

atr : attrdata; 

J : INTEGER; 
tempstr : strl; 

BEGIN 

tempstr CONCAT(voI id,'TEMPFILE.DTA'); 

ASSIGN(trfIle,tempstr); 

REWRITE(trflie); 
atr := NUL; 

ITMATTR[0] atr; 

FOR J :» 1 TO maxquaI IfIers DO 
BEGIN 

atr :« SUCC(atr); 

ITMATTR[J] :« atr 
END 

END; {In I tatr} 

PROCEDURE In ItpIckfVAR MARKrmarkarray;VAL:BOOLEAN); 

1 1n11 a marker array} 

VAR 

J : INTEGER; 
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BEGIN 

FOR J :* 1 TO maxattributes DO 
MARK[J] :« VAL 
END; {In?tpIck| 

PROCEDURE Keeptrack(numitm:INTEGER; atn-.attrnum; atr:attrdata; sel:CHAR); 
{Store the search criteria In a temporary file for later output} 

BEGIN 

IF zflag - 1 THEN numitm 0; {no Items met the requirements} 

WHILE NOT EOF(TrflIe) DO 
READ(TrfiIe,tree); 

WITH tree DO 
BEGIN 

nofltems :* numitm; 

atnum :« atn; 

atrbute ;* atr; 

seIect ion :« seI ; 

atname ;» A[atn].atname; 

qualname := A[atn].quals[ORD(atr)] 

END; 

WRITE(TrflIe,tree) 

END; {Keeptraek} 


BEGIN {Pickattr} 

If CHR(10); {linefeed character} 

COUNT 0; 

IT[0].I tern.Inum :« 0; {marks first time through procedure} 

{Searchfor uses this number to determine what data to accept} 
fnam :« CONCAT(voI Id, f I root,*IM.DTA*); 

INITatr; 

INITPICK(PICKED.FALSE); 

REPEAT 

SHOWATTR(PICKED.CHX); 

GETCODE(CH,CHX); 

IF CH <> * * THEN 
BEGIN 

atn ORD(CH) - 64; { change letter to attribute# } 

OKAY :« TRUE; WTIT TRUE; {default-no repetition, weight choices} 

IF PICKED[atn] THEN 
SELECTERR(OKAY,WTIT); 

IF OKAY THEN 
BEGIN 

PICKED[atn] :■ TRUE; {marker for selected item} 

IF WTIT THEN GETWEIGHT(WT); 

GETQUAL(atn,atr,selcode); 

SEARCHFOR(IT,atn,atr,FNAM.se I code,Zflag); 

SHOWORNO(SHOW,IT[0].1 tern.1num.ZfIag,dev); {dev is the output device} 

Keeptrack(It[0].item.inum,atn,atr.selcode); {*C**con: *P*«prn:} 

IF zflag - 0 THEN {a new list has been generated} 

Wtandrank(It,atn,atr,A[atn].qlnum,wt,wt1t); 

IF SHOW THEN 
BEGIN 

CH :■ *L*; {Show the ranked list} 

DUMPDATA(A,IT,atn,print,selcode,ch,dev); 

IF CH ■ *Y* THEN {Dump returned message to list data} 

BEGIN 

INITPICK(PRINT,FALSE); 

PRINT[atn] TRUE; {Mark attribute as selected} 

REPEAT 
clrscr; 
gotoxy(1,5); 

WRITELN(Spa(22),*A) List all attributes.*); 

WRITELN(Spa(22),’B) List selected attributes.*); 
gotoxyM ,22); 

Center(*Type in the LETTER of your choice.*); 

Rdupcase(ch) 

UNTIL CH IN [*A*,*B*]; 

IF CH - *A* THEN 

INITPICK(PRINT,TRUE) 

ELSE 

BEGIN 

REPEAT 

SHOWATTR(PRINT,CHX); 

GETCODE(CH,CHX); 

IF CH <> * * THEN 

(continued) 
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BEGIN 

TEMPatn :■ ORD(CH) - 64; j Change letter to attrubute#} 
PRINT[TEMPatn] ;■ TRUE; {Marker for selected item} 

END 

UNTIL CH - • • 

END; {ELSE} 

CH *Y*; { Reset value of ch so dump will list data } 

DUMPDATA(A,IT.atn.prInt.selcode.ch.dev) 

END; {If ch - *Y*} 

CH :■ *©' {Prevent accidental exit from main loop} 

END {If show} 

END {If okay} 

END {If ch <> * ’} 

UNTIL CH - * *; 

ERASE(TrfI Ie) 

END; {PICKATTR} 

PROCEDURE Loadatr(VAR A:attrtable; flroot:rootname; VAR exit:BOOLEAN); 

{Load and check attribute file} 

VAR 

J : INTEGER; 
fnam : strI; 
atf11e : af11e; 

BEGIN 
clrscr; 

fnam C0NCAT(volId,fI root,*AT.DTA*); 

ASSIGN(atflle.fnam); 

RESET(atfI Ie); 

READ(atf11e, A[0l); 

FOR J 1 TO A[0].atnum DO 
read (atfIle,a[J]); 

CLOSE(atfI Ie) 

END; {Loadatr} 

PROCEDURE Introsb; 

BEGIN 
clrscr; 
gotoxy (1,5); 

Center(’SEARCH DATA BASE’); 
wrIteIn; 

Centerf'The routine Is used to search for the Items which fit'); 

Centerf’the values or range of values which you select.*); 
gotoxyf1,22); 

Center(’Press any key to begin.'); 
repeat until keypressed; 
cIrscr 

END; {Introsb} 

BEGIN {Searchbase} 

Introsb; 
exit :« FALSE; 

Loadatr(atab le.fi root.ex 11); 

IF NOT exit THEN 
Pickattr(atable.fI root); 

END; 

PROCEDURE Addtobase(firoot:rootname; fI name:itern lab); 

{Collect and store the data for the materials in} 

{the MSP system. BTS 11/10/84 rev 4/10/85} 

VAR 

fdex : CHAR; 
itdex: INTEGER; 
atable : attrtable; 
itable : itemtable; 

PROCEDURE GETDATA(VAR A:attrtabIe;VAR I:itemtable; ITDEX;INTEGER;var fdexrchar); 
VAR {GET ITEM NAME AND VALUES OF EACH ATTRIBUTE} 

J.ITMCNT : INTEGER; 

CH : CHAR; 

NAMSTR : I tern lab; 

PROCEDURE FIXI (LSTR:strI;VAR ILAB:I tern Iab); 

VAR {CHANGE A STRING INTO AN ITEM LABEL} 

J:INTEGER; 
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BEGIN 
ILAB :« 

FOR J :■ 1 TO maxalablen DO 
ILAB CONCAT(ILAB, 1 ’); 

FOR J :« 1 TO LENGTH(LSTR) DO 
ILABfJl :« LSTR[J]; 

END; {FIXI} 


PROCEDURE PIacedata(inum.anum:INTEGER; ch:CHAR); 


BEGIN {Put qualifier va 

WITH I[inum] DO 

CASE ch OF 

’A’: Idata 

'anum' 

:* D1; 

’B’: Idata 

‘anum^ 

:» D2; 

’C’: Idata 

|anum' 

D3; 

•D’; Idata 

|anum’ 

:« D4; 

’E’: Idata 

|anum' 

:« D5; 

’F': Idata 

‘anurn* 

D6; 

*G*: Idata 

|anum' 

:* D7; 

’H’: Idata 

'anum^ 

D8; 

T: Idata 

|anum' 

:* D9; 

’J’: Idata 

'anum ( 

D10 

’X’; Idata 

lanum^ 

NUL 


END 

END; {Placedata} 


In the item record’s data array} 
{ten categories + NUL} 


PROCEDURE GetquaI(J,itmcnt;INTEGER); 

VAR 

K ; INTEGER; 
ch.chx : CHAR; 

BEGIN 
c I rscr; 

GOTOXY(1 ,4); 

WRITELN(Spa(15),’Attribute #*,A[J].atnum,*: ',A[J].atname); 
chx :* {char that is one before the letter ’A*} 

FOR K 1 TO A[J].qlnum DO 

BEGIN 

chx SUCC(chx); 

WRITELN(Spa(15),chx:3,': ’,A[J].qua Is[K]); 

END; 

REPEAT 

GOTOXYf1 , 15); 

Center(*Type in the LETTER of the qualifier that best describes’); 
WRITELN(Spa(20) , ’your item”s ’, A[ J] . atname) ; 

Center('Type the letter X for "No Data Available"’); 

Rdupcase(ch) 

UNTIL ch IN [ ’A’. .chx,’X’]; 

Placedata(Itmcnt,J,ch) 

END; {Getqual} 


PROCEDURE VERIFYITEM(VAR ITM:1temrec;ITMCNT:INTEGER); 
VAR {VERIFY DATA FOR AN ITEM.} 

CH.CHX ; CHAR; 

J,N,Iast : INTEGER; 


BEGIN 
REPEAT 
c I rscr; 
gotoxy(1,4); 

WRITELN(Spa(18),’VERIFY DATA FOR \ITM.iname,CHR(10)); 
WRITELN(Spa(17),’CODE ATTRIBUTE QUALIFIER’,CHR(10)); 

CHX *A*; 

Iast :« A[0].atnum; 

IF last <» 16 THEN 
FOR J 1 TO last DO 

BEGIN 

N ORD(ITM.Idata[J]); 

WRITELN($pa(18),CHX,’; •,A[J].atname:20,A[J].quals[N]:14); 

CHX SUCC(CHX) 

END 

ELSE 

BEGIN 

FOR J 1 TO 16 DO 

BEGIN 

N ORD(ITM.ldata[J]); 

WRITELN(’ ’,CHX,': ’,A[J].atname;20,A[J].qua Is[N]:14); 


(continued) 
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CHX :« SUCC(CHX) 

END; 

FOR J :« 17 TO lost DO 
BEGIN 

N :» ORD(ITM.ldoto[J]); 

GOTOXY(40,5+J); 

WRITELN(' ’.CHX.*; ’,A[J].atnome:20,A[J].quals[N]:14); 

CHX SUCC(CHX) 

END 

END; {ELSE} 

CHX PRED(CHX); {READJUST CODE} 

REPEAT 


GOTOXY(1,22); 

Centerf'Type o LETTER to change on Item or SPACEBAR to continue.'); 
Rdupcase(ch) 

UNTIL CH IN [’ \'A'..CHX]; 

lost ORD(CH) - 64; { CHANGE LETTER TO ATTRIBUTE #} 

IF CH <> ' ' THEN 
GETQUAL(last,ITMCNT) 

UNTIL CH - ' ' 

END; {VERIFYITEM} 


PROCEDURE GETNAME(VAR ILAB:Itemlab); 
VAR 

ch : CHAR; 
okay: BOOLEAN; 
len ; INTEGER; 

Itnam : stri; 


BEGIN 
clrscr; 

GOTOXYfl,4); 

Centerf'Please type in the name of the new item.’); 

WRITELN(Spa(20),'A name may not exceed ',maxaIabIen,’ characters. ’); 
REPEAT 

okay :•» FALSE: 

G0T0XYf5,7); 

READLN(con.Itnam); 

LEN LENGTH(itnam); 

IF LEN > maxalablen THEN 
BEGIN 

GOTOXYfl.22); 

Centerf'Too many characters In the name') 

END 

ELSE 

BEGIN 

FlXI(Itnam.llob); 

REPEAT 

GOTOXYfl,22); 

Centerf’Press E to change (edit) name. Press C to continue’); 
Rdupca8e(ch); 

GOTOXY(1,21); del line; del line 
UNTIL ch IN ['C’.’E’]; 

IF ch - 'C' THEN 
okay TRUE 

END 

UNTIL okay 
END; {GETNAME} 

BEGIN {Getdata} 

l[0].iname A[0].atname; {database name} 

ITMCNT 0; 

REPEAT 

ITDEX ITDEX + 1; 

ITMCNT ITMCNT + 1; 

GETNAME(NAMSTR); 

ifitmcnt].fId fdex; {file identifier } 

itITMCNT1.iname NAMSTR; 

I[ITMCNTJ.inum ITDEX; 
c I rscr; 
gotoxy(1,4); 

WRITELN(Spaf18),A[0].atname); 

WRITELN(Spa(18) •’Get attributes for ’,NAMSTR); 

FOR J := 1 TO A[0].atnum DO 
GETQUAL(J,ITMCNT); 

VERIFYITEM(I[ITMCNT],ITMCNT); 
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Center('Type "Q" to quit, any other key to enter another item.’); 

Rdupcase(ch); 

UNTIL ch - 'Q'; 

l[0].inum :« ITDEX; {total number of Items now in the list} 

END; {GETDATA} 

PROCEDURE Putawayd(VAR I;Itemtable; f1 root:rootname); 

VAR {Save items to file} 

J.fnsh : INTEGER; 
fnam: stri; 

Itf11e : Ifile; 

Itrec : itemrec; 

BEGIN 

fnam :« CONCAT(voI id,firoot,*IM.DTA'); 

ASSIGN(11 file.fnam); 

RESET(Itflie); 

READ(Itfile,itrec); 

fnsh :* l[0].inum - itrec.inum; {# of items to be added to the file} 

IF fnsh > 0 THEN 
BEGIN 

itrec I[0]; 

SEEK(Itfile,0); 

WRITE(ItfIle,Itrec); 

$EEK(Itfile,FileSize(Itfile)); {go to end of file} 

FOR J :• 1 TO fnsh DO 
wr11 e(11 fiIe,I[j]); 

END; 

CLOSE(Itfile) 

END; {Putawayd} 

PROCEDURE Loadatrx(VAR Aiattrtable; f l root:rootname; VAR ITDEX:INTEGER; VAR fdexichar); 
VAR {load attribute table and check IM file } 

J : INTEGER; 
fnam : strI; 
atfiIe : afile; 
itfile : ifile; 

Itrec: itemrec; 

BEGIN 
clrscr; 

fnam :« CONCAT(volld.firoot,'AT.DTA*); 
assign (atfile.fnam); 

RESET(at f1 Ie); 
read (atfI Ie,o[0]); 

FOR J :« 1 TO A[0J.atnum DO 
read (atf11e.a[j]); 

CLOSE(atfile); 

fnam :« CONCAT(voI Id,firoot,'IM.DTA*); 
assign (itfIle.fnam); 

RESETHtf I le); 
read (itfIle,itrec); 

ITDEX itrec.inum; 
fdex :■ itrec.fid; 

SEEK(itfI Ie,ITDEX); 

READ(itfI Ie,Itrec); 
cIrscr; gotoxy(1 ,4) ; 

WRITELN(Spa(18),'there are **itdex,’ items in *,a[0].atname); 

IF itdex > 0 THEN 

WRITELN(Spa(18),'The last Item in the list is: \itree.iname); 
gotoxyfl,21); 

Center('Press any key to continue.'); 
repeat until keypressed; 

CLOSE(Itfile) 

END; {Loadatrx} 

PROCEDURE Introab; 

BEGIN 
clrscr; 
gotoxy (1.8); 

Center('ADD DATA'); 

wrlteln; 

wr IteIn; 

Center(*This routine is used to add Items to the data base. '); 
wr iteln; 

WRITELN(Spa(15),'An Item''s name may not exceed *.rnaxaIabIen,* characters.'); 


(i continued ) 
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gotoxyf1,21); 

Center('Press any key to begin.'); 
repeat until keypressed; 
cIrscr 

END; }Introab} 

BEGIN {Addtobase} 

Introab; 

Loadatrx(atabIe,f1 root,ITDEX,fdex); 

Getdata(atabIe,ltab Ie,ITDEX,fdex); 

Putawayd(I tab le.fi root) 

END; 

PROCEDURE Newbase(f1 root;rootname;f1 name:itemlab); 
{Create attribute table for a data base} 
jBTS 10/24/84 rev 4/10/84 10/3/85} 

VAR 

acount ; INTEGER; 
exit : BOOLEAN; 

Atable : Attrtable; 


PROCEDURE FIXQ (LSTR:strl;VAR QLAB:qua I Iab); 

VAR {change a string Into a qualifier 

J:INTEGER; 

BEGIN 

QLAB 

FOR J :■ 1 TO maxqlablen DO 
QLAB CONCAT(QLAB,' '); 

FOR J 1 TO LENGTH(LSTR) DO 
QLAB[J] LSTR[J] 


END; {FIXQ 


IabeI} 


PROCEDURE BIankattr(VAR A:Attrrec); 

VAR {Initialize an attribute record} 

J : INTEGER; 

BEGIN 

A.atnum :■ 0; 

A.atname ;■ 

A.qlnum 0; 

Flxq('No data',A.qua Is[0]); 

FOR J :■ 1 TO maxquaIlf1ers DO 
A.quaIsfJ] :* *' 

END; {Blankattr} 

PROCEDURE GETATTR(VAR A:Attrrec;VAR acount:INTEGER;VAR exit: BOOLEAN); 
VAR {Get an attribute name} 

LEN : INTEGER; 
atrSTR : attrlab; 

LABSTR : strl; 

CH : CHAR; 
okay : BOOLEAN; 


BEGIN 


okay :* FALSE; {assume bad input} 
cIrscr; 

REPEAT 

GOTOXY(1, 5); 

WRITELN(Spa(5),'Please type In a name for attribute #',acount,': ')• 
READLN(con,labstr); 
len LENGTH(Iabstr); 

IF len IN [1..maxaIabIenl THEN 
BEGIN 


Fixa(labstr,atrstr); 
A.atnum :■ acount; 
A.atname :* atrstr; 
okay TRUE 


END 

ELSE IF len <> 0 THEN 

WRITELN(Spa(10),*A name may not exceed ',maxaIabIen,' characters.') 

LLdt 

BEGIN 

GOTOXY(1.20); 

WRITELN(Spa(10),’You have not typed in any name for attribute ’ acoi 
Center(*Press the LETTER "Q" to confirm that this is okay.’); 

Center(’Press any other key to go back.’); 

Rdupcase(ch); clrscr; 


t) 


122 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 




J uly 


IF ch - ’Q* THEN exit := TRUE 
END 

UNTIL okay OR exit 
END; {GETATTR} 

PROCEDURE GETQUAL(VAR A:Attrrec; acount:INTEGER); 

VAR {Get qualifier names for an attribute} 

QCOUNT,LEN ; INTEGER; 

QLSTR : qua I lab; 

LABSTR ; stri; 

CH : CHAR; 

BEGIN 

LEN :« 1; QCOUNT 0; 
clrscr; 
gotoxy(30,5); 

WRITELN(Spa(5),'Attribute #'.acount,* *.A.atname); 

WRITELN; 

WRITELN(Spa(5),'Qualifier Number (The limit is *.maxquaIifiers,*)*); 

WHILE (qcount < maxquaI 1fiers) AND (len <> 0) DO 
BEGIN 

GOTOXY(1, 21); 

Center('Press RETURN to exit.'); 

GOTOXY(12,10+qcount); 

WRlTE(qcount+1:2,': '); 

READLN(con,labstr); 

LEN LENGTH(LABSTR); 

IF LEN IN [1..maxqlablen] THEN 
BEGIN 

FIXQ(LABSTR,QLSTR); 
qcount :* qcount + 1; 

A.qua Is[QCOUNT] :■ QLSTR {A.quals[0] defaults to 'No data'} 

END 

ELSE IF LEN <> 0 THEN 
BEGIN 

GOTOXY(20,20); 

WRITELN(Spa(10),'A name may not exceed '.maxqlablen,' characters.'); 

G0T0XY(1,10+qcount); clreol 
END 
ELSE 
BEGIN 

gotoxy(20,20); 

WRITELN('You have entered '.QCOUNT.' qualifiers.'); 

Centerf'Press the LETTER M Q" to confirm that you are finished.'); 

Center('Press any other key to add more qualifiers.'); 

Rdupcase(ch); 

GOTOXY(1,20); del line; del line; del line; 

IF CH - 'Q' THEN LEN 0 
ELSE LEN 1 
END; 

END; {while} 

A.qlnum qcount {store the # of qualifiers in the record} 

END; {Getqual} 

PROCEDURE Checkaq(VAR A:attrtab Ie); 

VAR {show list and allow user to edit it} 

J.K.ANUM.N : INTEGER; 

CH.CHX ; CHAR; 

OKAY : BOOLEAN; 

PROCEDURE EDITQ(J.N:INTEGER); {EDIT qualifiers} 

VAR 

LEN ;INTEGER; 

LABSTR ; stri; 

QLSTR : qua I lab; 

BEGIN 

REPEAT 

gotoxyf1,21); 

Centerf'Type in a new qualifier name'); 

Center('Press RETURN to continue.'); 

READLN(con,labstr); 

LEN LENGTH(LABSTR); 

IF LEN <> 0 THEN 

IF LEN IN [1..maxqlablen] THEN 
BEGIN 

( continued ) 
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FIXQ(LABSTR.QLSTR); 

A[J].qua Is[N] QLSTR 
END 
ELSE 

WRITELN(Spa(13), *A name may not exceed *,maxqIabIen, 
UNTIL LEN IN [0..maxqIabIenl 
END; {EDITQ} 

PROCEDURE EDITA(J:INTEGER); {EDIT ATTRIBUTE NAME} 

LEN : INTEGER; 

LABSTR : strl; 
atrSTR : attrlab; 

BEGIN 

REPEAT 

gotoxyM ,21); 

Centerf'Type In a new attribute name*); 

CenterC‘Press RETURN to continue.*); 

READLN(con,Iabstr); 

LEN :« LENGTH(LABSTR); 

IF LEN <> 0 THEN 

IF LEN IN [1..maxalablen] THEN 
BEGIN 

FIXA(LABSTR,atrSTR); 

A[J].atname :« atrSTR 
END 
ELSE 

WRITELN(Spa(13),*A name may not exceed *,maxaIabIen,* 
UNTIL LEN IN [0..maxalablenl 
END; {EDITA} 

BEGIN {Checkaq} 
c I rscr; 

Center(*Check and edit attributes and qualifiers.*); 
WRITELN(A[0].atname); 

ANUM :■ A[0J.atnum; 

IF anum >■ 1 THEN 
FOR J 1 TO ANUM DO 
REPEAT 

OKAY :« FALSE; clrscr; 

GOTOXY(l,2); 

CHX :■ 

WRITELNf‘ATTRIBUTE #*,A[J].atnum); 

WRITELN(CHX,*: *,A[J].atname); 

IF A[J].qInum > 0 THEN 
BEGIN 

FOR K :« 1 TO A[J].qlnum DO 
BEGIN 

CHX :« SUCC(CHX); 

WRITELN(CHX:3,*: *,A[J].qua Is[K]); 

END; 

REPEAT 

GOTOXYM, 21); 

Center( *Type @ to change the attribute name,’); 
Center(*a LETTER to change a qualifier name or*); 
Center(‘Press the SPACE BAR to continue. *); 
Rdupcase(ch) 

UNTIL CH IN [• •,*®*..CHX]; 

IF CH - ’©* THEN 
EDITA(J) 

ELSE IF CH IN [*A*..CHX] THEN 
BEGIN 

N :« ORD(CH) - 64; {change char to qualifier #} 
EDITQ(J.N) 

END 

ELSE 

OKAY TRUE 
END (*if A[J].qlnum*) 

UNTIL OKAY 
END; {Checkaq} 

PROCEDURE Putawaya(A:attrtabIe; ft root;rootname); 

VAR 

J : INTEGER; 
fnam : strl; 


* characters 


characters.* 
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at f fIe : afI Ie; 

BEGIN 
c | r s c r * 

fnam CONCAT(volid.firoot,*AT.DTA*); 
assign(atfiIe,fnam); 

RESET(atf He); 

FOR J :« 0 TO A[0].atnum DO 
wr !te(atfI Ie,a[j]); 

CLOSE(atfI Ie) 

END; {Putawaya} 

PROCEDURE Intronb; 

BEGIN 
clrscr; 
gotoxy (1,8); 

Center('CREATE DATA BASE SHELL*); 
wrIteln; 
wrIteIn; 

Centerf’This routine Is used to name;*); 

CenterC'the data base**s attributes and their qualifiers*); 
gotoxyM ,21); 

Center(’Press any key to continue.*); 

REPEAT UNTIL KEYPRESSED; 

END; |Intronb} 

BEGIN {Newbase} 

Intronb; 
exit :« FALSE; 

AtabIe[0].atname :* finame; 
acount :« 1; 

WHILE (acount <« maxattributes) AND (NOT exit) DO 
BEGIN 

BIankat t r(AtabIe[acount]); 

Getattr(AtabIe[acount],acount.exit); 

IF (acount - 1) AND (exit - TRUE) THEN 
acount 0; 

IF (NOT exit) THEN 
BEGIN 

Getqua 1(Atab1e[acount],acount); 
clrscr; 

GOTOXY(1,5); 

WRITELN($pa(10),*You have finished creating *,acount,* attribute(s).*); 

WRITELN(Spa(10),*The latest of which was *.AtabIefacount].atname); 

WRITELN; 

WRITELN(Spa(10),*A) Create another attribute.*); 

WRITELN(Spa(10),*B) Go on to the next step (edit the entries).*); 

GOTOXY(1,21); 

Center(*Type In the LETTER of your choice.*); 

REPEAT Rdupcase(ch) UNTIL ch IN [*A’,’B*]; 

IF ch - ’B* THEN exit TRUE 
ELSE acount :■ acount + 1 
END; Iif not exit} 

AtabIe[0].atnum :« acount 
END; {while} 

IF acount > 0 THEN 
BEGIN 

Checkaq(Atable); 

Putawaya(AtabIe.firoot) 

END 

END; (*Newbase*) 

PROCEDURE Mainmenu (VAR ch:CHAR); 

BEGIN 
Clrscr; 
gotoxyM,5); 

Center(*Materia18 Selection Program*); 

GOTOXYM. 8); 

Center(’MAIN MENU*); 

GOTOXY(I.II); 

WRITELN(Spa(22),*A) Create a new data base*); 

WRITELN(SpaC22),*B) Add data to an existing data base*); 

WRITELN(Spaf22).*C) Search for selected items*); 

WRITELN(SpaC22),*D; Remove a data base*); 

WRITELN(Spa(22),*E) System overview*); 

WRITELN(Spa(22),*Q) Quit the program’); 

gotoxy (1.21); (cMtinuaft 
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Canter('Type In the LETTER of your choice’); 
Rdupcose(ch) 

END; (*Mainmenu*) 

PROCEDURE Intromaln; 

BEGIN 

textbackground(7); 
textcolor(l); 
clrscr; 
gotoxy(1,5); 

Center(’MATERIALS SELECTION PROGRAM’); 
gotoxyi1,9); 

CenterC’wrItten by'); 

Center(’Bro. Tom Sawyer, esc and Michael Pecht*); 
wr IteIn; 
write In; 

Center(’MeehanIcaI Engineering Department'); 
Center!'University of Maryland*); 

Center(*CoI Iege Park MD 20742'); 

Center('(301) 454-8866'); 
gotoxyf1,21); 

Center('Press any key to continue.'); 

REPEAT UNTIL KEYPRESSED; 

END; {Intromaln} 


PROCEDURE Explain; {Give an overview of the system and its use} 

BEGIN 
clrscr; 

GOTOXYf1,4); 

Center('SYSTEM OVERVIEW'); 

WRITELN; 

Center(’TERMS:'); 

WRITELN; 

Center('ATTRIBUTE - A physical property or characteristic of the material 
WRITELN; 

Center('QUALIFIER - One of a range of values that describes the property. 
WRITELN; 

Center('RELATIVE IMPORTANCE - The weight you wish to give to an attribute 
Center('relatIve to the other attributes your "ideal" material must have. 
WRITELN; 


Center('PIVOT - This is the MINIMUM acceptable value for the qualifier 
WRITELN; H 

Center(’RANGE - Qualifier values around the pivot.'); 

Centerf'You may choose only the pivot or all values on either side of it. 
Center('The farther away a value lies from the pivot, the more weight it 
Center('is given in the calculation of overall acceptability (rank) 
G0T0XY(1.23); V ' 


Center('Press ANY KEY to return to the main menu.'); 
REPEAT UNTIL Keypressed 
END; {Explain} 


: S; 


BEGIN {MAIN PROGRAM - MSP} 

Intromaln; 

volld :* 'A:'; {this Is the Id of the data file volume} 
REPEAT 

exit :« FALSE; 

Mainmenu(ch); 

IF ch IN ['A*..*D*] THEN 
Get fI name(fI root,fI name,ch,exit); 

IF NOT (exit) THEN 
CASE ch OF 

'A*; Newbase(fIroot,finame); 

*B*: Addtobase(fI root,finame); 

'C': Searchbase(fI root,fIname); 

'E': Explain 
END 

UNTIL ch - *Q*; 
textbackground(0); 
clrscr 
END. 
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"A Material Selection Program," by Brother Tom Sawyer and 
Michael Pecht. July, page 235. 


MSP by Brother Tom Sawyer, esc, and Michael Pecht, Mechanical Engineering 
Department, University of Maryland, College Park, MD 20742. Drive for data 
files set to A:. You can change the assignment of <volid> in the main 

block or insert a user input option. 


srchfor.pas 

"A Material Selection Program," by Brother Tom Sawyer and 
Michael Pecht. July, page 235. 


PROCEDURE Searchfor(VAR It:ranktabIe; atniattrnum; atr:attrdata; 

fnam:stri; seI code:CHAR; VAR Zflagiflag); 

{Get data from file or from ranktable. It[0] used to pass values to output} 
VAR 

memsrch : BOOLEAN; 

J.cnt.last : INTEGER; 
itrec : itemrec; 
tempatr : attrdata; 
itfiIe:Ifile; 

PROCEDURE Checkrec(VAR ent:INTEGER); 

{look for data in It or on disk} 

{changes It and uses seI code,tempatr,atr.memsrch, and j} 

VAR 

match ; BOOLEAN; 

BEGIN 

match :■ FALSE; 

CASE selcode OF 

'A' : IF tempatr <« atr THEN match :* TRUE; 

’B’ ; IF tempatr - atr THEN match := TRUE; 

■C* : IF tempatr >« atr THEN match := TRUE 

END; {case} 

IF (memsrch) AND (tempatr * NUL) THEN {Include "no data" items} 
match :■* TRUE; 

IF match THEN 
BEGIN 

ent ent + 1; 

IF memsrch THEN {data is in It} 

It[cnt] :■ It[J] 

ELSE {data is on disk} 

BEGIN 

It[cntl.rating :■ 0; {initialize rating} 

It[cntJ.item :* itrec 
END 

END {if match} 

END; {Checkrec} 

BEGIN {Searchfor} 
ent :« 0; 

Zflag 0; {assume no data is present} 

last :« It[0].itern.Inum; 

IF last = 0 THEN {search disk file} 

BEGIN 

memsrch :=* FALSE; 

ASSIGN(itflle,fnam); 

RESET(itfiI•); 

READ(Itflle,itrec); 

It[0].I tern.Iname :■ itrec.iname; {data base name} 

WHILE NOT E0F(ItflIe) DO 
BEGIN 

READ(ltfIle,Itrec); 


{continued) 
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tempatr :« itrec.ldata[atn]; 

Checkrec(cnt); 

END; 

CLOSE(11fI I e); 

IF cnt - 0 THEN Zflag :« -1 {No items found in data base} 

END {last-0} ’ 

ELSE {search array It} 

BEGIN 

memsrch TRUE; 

FOR J 1 TO last DO 
BEGIN 

tempatr IT[J].I tern.idata[atn]; 

Checkrec(cnt) 

END; 

IF cnt - 0 THEN Zflag 1 {No Items In It fit the new constraint} 

END; {else} 

It[0].Item.idata[0] atr; {desired qualifier value} 

IF Zflag <> 1 THEN {change item count. New list or no items in data base} 
IT[0J.Item.inum cnt 

END; {Searchfor} 


wtrank.pas 

"A Material Selection Program." by Brother Tom Sawyer and 
Michael Pecht. July, page 235. 


PROCEDURE Wtandrank(VAR It:Ranktable;atn:attrnum;atrrattrdata; 

VAR qlnrqualnum ;wt:INTEGER; wtit:BOOLEAN); 

J,last.baseval.atrval : INTEGER; 

PROCEDURE Rank Iist(VAR ItiRanktable; Iast:INTEGER); 

VAR {selection sort by decreasing rating} 

J,K,hdx ; INTEGER; 
switch : BOOLEAN; 
high : rankltemrec; 

BEGIN 

FOR J 1 TO last-1 DO 
BEGIN 

switch :« FALSE; 

high :« It[J]; hdx J; 

FOR K J + 1 TO last DO 

IF It[K].rating > high.rating THEN 
BEGIN 

switch :« TRUE; 
high :« It[K]; 
hdx :« K 
END; {if} 

IF switch THEN {must switch places} 

BEGIN 


It[hdx] It[J]; 
It[J] :« high 


END 
END {for J} 

END; {Rank list} 

BEGIN {Wtandrank} 
baseval := ORD(atr); 

last :» It[0].item.Inum; {# of Items in array} 

FOR J ;■ 1 TO last DO 

BEGIN 

atrval :« ORD(It[J].Item.Idatafatn]); 

IF (wtit) AND (atrval > 0) THEN 
It[jj. - 

END; 

IF wtit THEN 
Rank I 1st(It,Iast) 

END; {Wtandrank} 


\UUYUI * KJ J 1 nciN 

.rating := It[J].rating + ROUND(wt*ABS(baseval-atrval)/qln) 
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coIc.mod 


Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


EMODULE Calc; 

(* A simple spreadsheet program. 

Copyright 1986 by Jonathan Amsterdam. All Rights Reserved. 

*) 

FROM Spreadsheet IMPORT setValue, getValue, setFormula, getFormula, 

maxRow, maxCol, setAutomatic, setManual, recalculate, 
operationStatus, Status, clearAII; 

IMPORT Spreadsheet; 

FROM DispIayHandIer IMPORT setCorner, setPrecIsion, setColWidth, 
moveCursor, message; 

IMPORT DispIayHandIer; 

FROM CommandProc IMPORT command, CommandType, readCommand; 

FROM Misc IMPORT fatal; 

FROM Terminal IMPORT Beep; 

PROCEDURE init; 

BEGIN 

Spreadsheet.Init; 

DisplayHandler.init; 

END init; 


PROCEDURE doLoop; 

VAR c:command; 

currCelI Row, currCelI Co I:CARDINAL; 
BEGIN 

currCeIIRow :■ 1; 
currCeIICoI :« 1; 

LOOP 


readCommand(c, currCelIRow, currCeIICoI); 

CASE c.type OF 

CellRef: newCurrCeI I(currCeI I Row, currCellCol, c.row, c.col); 

| SetValue: setVaIue(currCeI I Row, currCellCol, c.value); 

checkStatus; 

| SetFormula: setFormula(currCelIRow, currCellCol, c.form); 
checkStatus; 

| Left, Right, 

Up, Down: IF moveCursor(c.type) THEN 

moveCurrCelI(currCelIRow, currCelI Co I, c.type); 


NewCorner: 

Precision: 

ColWidth: 

Automatic: 

ManuaI: 

RecaIc: 

Copy: 

Clear: 

Quit: 


END; 

setCorner(c.row, c.col); 
setPrecision(c.precis ion); 
setColWidth(c.colWidth); 
setAutomatic; 
setManuaI; 
recaIculate; 

doCopy(currCeIIRow, currCellCol, c.row, c.col); 
cIearAII; 

EXIT; 


ELSE 


fatal('doLoop: unknown command type'); 

END; 

END; 

END doLoop; 


PROCEDURE doCopy(fromRow, fromCol, toRow, toCoI:CARDINAL); 
VAR v:REAL; 

BEGIN 

(* check for status? *) 

setValue(toRow, toCol, getVaIue(fromRow, fromCol)); 
setFormula(toRow, toCol, getFormuIa(fromRow, fromCol)); 
END doCopy; 


PROCEDURE newCurrCeI I(VAR currCelIRow, currCeIICoI:CARDINAL; 

row, coI:CARDINAL); 


(continued) 
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BEGIN 

IF (row >- 1) AND (row <- moxRow()) AND (col>»1) AND (col <- maxColQ) THEN 
currCeI I Row :■ row; 
currCeIICoI :■ coI; 

ELSE 

Beep; 

END; 

END newCurrCeI I; 

PROCEDURE moveCurrCelI(VAR currCellRow, currCeIICoI;CARDINAL; 

direction:CommandType); 

BEGIN 

CASE direction OF 

Up: IF currCellRow > 1 THEN DEC(currCeI I Row); ELSE Beep; END; 

Down: IF currCellRow < maxRow() THEN INC(currCeI I Row); ELSE Beep; END; 

Left: IF currCeHCof > t THEN DEC(currCe I ICol ); ELSE Beep; END; 

Right: IF currCellCol < maxColQ THEN INC(currCeIICol); ELSE Beep; END; 

ELSE 

fatal(‘moveCurrCelI: unknown direction'); 

END; 

END moveCurrCeI I; 

PROCEDURE checkStatus; 

BEGIN 

CASE operatlonStatus OF 

OK: (* do nothing *); 

| RangeError: message("Out of range"); 

ELSE 

Beep; 

END; 

END checkStatus; 


BEGIN 

In 11; 
doLoop; 
END Calc. 


disklo.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Disk 10; 

(* For low-level I/O to a temporary disk file. Used in the virtual 
implementation of the spreadsheet. 

The Volume stuff is specific to MacModuIa-2's implementation of 
the file system. You will have to make changes for your system. 

Can't mix reading and writing: only reads can occur between a startRead 
and an endRead, and similarly for writes. 


FROM FileSystem IMPORT File, Volume, ReadBytes, WriteBytes, SetPosition, 

Vo IumeDriveName, OpenVolume, Interna I Dr IveNumber, Create, OpenFile, 
CloseVolume, CloseFile, Delete, fiIeErrSysEnabIe, GetFiIeLength; 

FROM MyStorage2 IMPORT ALLOCATE, DEALLOCATE; 

FROM Misc IMPORT assert, fatal; 

FROM SYSTEM IMPORT TSIZE, ADR, ADDRESS; 

FROM StringStuff IMPORT stringLen; 

CONST sectorSize * 512; (* bytes per sector; must be power of 2 *) 

maxCardinaILog2 « 16; (* equivalent to # of bits in a CARDINAL *) 

sectors IzeLog2 * 9; (* log base 2 of sector size *) 

maxSectorsPerAddress ■ 10; (* max sectors in one disk address *) 

f1 IeName « "sstemp"; 
bytesPerWord ■ 2; 

TYPE Sector - CARDINAL; 

DiskAddress « POINTER TO daRec; 
daRec * RECORD 
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size:CARDINAL; 

contents:ARRAY[1..maxSectorsPerAddress] OF Sector; 
END; 

SectorList « POINTER TO sectorRec; 
sectorRec * RECORD 

sector -.Sector; 
next:SectorList; 

END; 


VAR sectorsWrItten:ARRAY[1..maxSectorsPerAddress] OF Sector; (* for writing 


nSectorsWritten: [0..maxSectorsPerAddress] 
curDiskAddress:DiskAddress; 
nSectorsRead:[0..maxSectorsPerAddress]; 
freeSectors: SectorList; 
posInSector:CARDINAL; 


*> 

♦) 


nextSector:CARDINAL; (* 
file: File; (* 

volume:Volume; 
rewriting:BOOLEAN; (* 

sectorsPerHigh:CARDINAL; 


next available sector 
the scratch file *) 


(* for writing k rewriting 
for reading k rewriting *) 
for reading *) 
list of free sectors *) 
position in current sector *) 
in file (at end of file) *) 


TRUE if we are rewriting existing sectors *) 

(* § of sectors represented by a 1 in the high 
CARDINAL of SetPosition. See goToSector. *) 


PROCEDURE init; 

VAR i:CARDINAL; 

BEGIN 

freeSectors :» NIL; 
nextSector :* 0; 
posInSector := 0; 
sectorsPerHigh :■ 1; 

FOR I :« 1 TO maxCardinalLog2 - sectorSizeLog2 DO 
sectorsPerHigh :■ 2 * sectorsPerHigh; 

END; 

makeScratchFiIe; 

END init; 

PROCEDURE clear; 

VAR temp:SectorLIst; 

BEGIN 

CloseFile(file); 

DeIete(voIume, fileName); 

CloseVoIume(voIume); 

WHILE freeSectors <> NIL DO 
temp :* freeSectors; 
freeSectors :* freeSectors^.next; 

DISPOSE(temp); 

END; 

END clear; 

PROCEDURE makeScratchFile; 

(* Create a new file. This is Mac-specific. Change for 
your own system. 

With the MacModula-2 file system, you first have to open a volume 
(I.e. disk), then create the file, then open it. With most other 
file systems, probably a single call to Create will do it. *) 

VAR vname:ARRAY[0..26] OF CHAR; 

BEGIN 

VolumeDriveName(Interna I DriveNumber, vname); 

(* Use the disk in the Mac's internal disk drive *) 

OpenVoIume(voIume, vname); 

fiIeErrSysEnabIe :■ FALSE; (* Turn off default error handling *) 

DeIete(voIume, fileName); (* Delete the file, if it exists *) 

f 11eErrSysEnable :- TRUE; (* Turn on error handling *) 

Create(volume, fileName, "????", "????"); 

(* The last two args are creator and filetype; they're unimportant. *) 
OpenF1 Ie(fI Ie, volume, fileName); 

END makeScratchFile; 


PROCEDURE startWrite; 

BEGIN 

nSectorsWrItten :■ 0; 
rewriting :- FALSE; 
posInSector :■ sectorSIze; 

END startWrite; 

(continued) 
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PROCEDURE endWrIte():DiskAddress; 

VAR da:01skAddress; 

I:CARDINAL; 

BEGIN 

assert(nSectorsWrItten <> 0, "endWrite: nothing written"); 

(* allocate just enough space for the number of sectors written *) 
da :■ newDiskAddress(nSectorsWritten); 

FOR i 1 TO nSectorsWrItten DO 

da".contents[1] :■ sectorsWritten[i]; 

END; 

RETURN da; 

END endWrite; 

PROCEDURE startRewrIte(da:DiskAddress); 

BEGIN 

rewriting :■ TRUE; 
curDiskAddress :■ da; 
nSectorsWr1tten 0; 
posInSector sectorSize; 

END startRewr1te; 

PROCEDURE endRewrIte():DIskAddress; 

VAR newda:DiskAddress; 

I:CARDINAL; 

BEGIN 

assert(nSectorsWr1tten <> 0, "endRewrite: nothing written"); 

IF nSectorsWritten - curDiskAddress*.size THEN 
RETURN curDiskAddress; 

ELSE 

newda :* newDiskAddress(nSectorsWritten); 

IF nSectorsWritten < curDiskAddress".size THEN 
FOR 1 :« 1 TO nSectorsWritten DO 

newda".contents[i] :« curDiskAddress".contentsTI]; 

END; 

FOR I :« nSectorsWritten+1 TO curDiskAddress".size DO 
freeSector(curDiskAddress".contents[i]); 

END; 

ELSE 

FOR I :■ 1 TO curDiskAddress".size DO 

newda".contents[i] curDiskAddress".contentsfi]; 

END; J 

FOR i curDiskAddress".size+1 TO nSectorsWritten DO 
newda".contentsfi] :■ sectorsWrittenfi]; 

END; 

END; 

freeDiskAddress(curDiskAddress); 

RETURN newda; 

END; 

END endRewrite; 

PROCEDURE startRead(da:DiskAddress); 

BEGIN 

curDiskAddress :=* da; 
nSectorsRead :« 0; 
posInSector :* sectorSize; 

END startRead; 

PROCEDURE endRead; 

BEGIN 

(* There is nothing to do when a read is ended, but I leave this procedure 
here for symmetry. *) 

END endRead; 

PROCEDURE WriteReaI(r:REAL); 

BEGIN 

WrIteNBytes(ADR(r), TSIZE(REAL)*bytesPerWord); 

END WrlteReaI; 

PROCEDURE ReadReaI(VAR r:REAL); 

BEGIN 

ReadNBytes(ADR(r), TSIZE(REAL)*bytesPerWord); 

END ReadReaI; 

PROCEDURE WrIteString(VAR s:ARRAY OF CHAR); 

(* Assumes strings <* 255 chars *) 

VAR Ien:CARDINAL; 
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clen:ARRAY[0..1] OF CHAR; 

BEGIN 

len :*= stringLen(s); 

assert(len <« 255, "DisklO.WriteString: too long"); 
cIen[0] CHR(len); 

Wr I teNBytes(ADR(cIen), 1); 

Wr fteNBytes(ADR(s), len); 

END WriteString; 

PROCEDURE ReadStrlng(VAR s:ARRAY OF CHAR); 

VAR Ien:CARDINAL; 

cIen:ARRAY[0..1] OF CHAR; 

BEGIN 

ReadNBytes(ADR(clen), 1) ; 
len :« ORDfcIen[0]); 

ReadNBytes(ADR(s), len); 

s[ I en] 0C; 

END ReadStrlng; 

PROCEDURE WrIteCard(c:CARDINAL); 

BEGIN 

WriteNBytes(ADR(c), TSIZE(CARDINAL)*bytesPerWord); 

END WriteCard; 

PROCEDURE ReadCard(VAR c:CARDINAL); 

BEGIN 

ReadNBytes(ADR(c), TSIZE(CARDINAL)*bytesPerWord); 

END ReadCard; 

PROCEDURE WriteNBytes(a:ADDRESS; count:CARDINAL); 

VAR leftInSector:CARDINAL; 

BEGIN 

IF count <> 0 THEN 

IF posInSector ■ sectorSize THEN (* this sector full; get another *) 
newSector; 

assert(posInSector • 0, "WrIteNBytes; failed to get new sector"); 
END; 

leftlnSector :« sectorSize - posInSector; 

IF count > leftlnSector THEN 
WriteBytes(fiIe, a, leftlnSector); 

INC(po9InSector, leftlnSector); 

INC(a, leftlnSector); 

WrIteNBytes(a, count-1 eftInSector); 

ELSE 

WriteBytes(flle, a, count); 

INC(posInSector, count); 

END; 

END; 

END WriteNBytes; 

PROCEDURE ReadNBytes(a;ADDRESS; count CARDINAL); 

VAR leftlnSector, actuaI:CARDINAL; 

BEGIN 

IF count <> 0 THEN 

IF posInSector * sectorSize THEN 
INC(nSectorsRead); 

WITH curDiskAddress^ DO 

IF nSectorsRead > size THEN 

fata I("ReadNBytes: attempt to read too much"); 

ELSE 

goToSector(contents[nSectorsRead]); 
posInSector :■ 0; 

END; 

END; 

END; 

leftlnSector sectorSize - posInSector; 

IF count > leftlnSector THEN 

ReadBytes(fIle, a, leftlnSector, actual); 

assert(actual - leftlnSector, "ReadNBytes: actual <> leftlnSector"); 
INC(posInSector, leftlnSector); 

INC(a, leftlnSector); 

ReadNBytes(a, count-1 eftInSector); 

ELSE 

ReadBytes(f11e, a, count, actual); 


(continued) 
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assert(actuaI - count, "ReadNBytes: actual <> count"); 

INC(posInSector, count); 

END; 

END; 

END ReadNBytes; 

PROCEDURE newSector; 

BEGIN 

INC(nSectorsWrltten); 
posInSector :■ 0; 

IF rewriting THEN 

IF nSectorsWrItten > curDlskAddress^.size THEN 
brandNewSector; 

ELSE 

goToSector(curDIskAddress".contents[nSectorsWrIttenl); 

END; 

ELSE 

brandNewSector; 

END; 

END newSector; 

PROCEDURE brandNewSector; 

VAR tempiSectorLIst; 

BEGIN 

IF freeSectors <> NIL THEN 

sectorsWrItten[nSectorsWrItten] :■ freeSectors".sector; 

goToSector(freeSectors".sector); 

temp :« freeSectors; 

freeSectors :* freeSectors".next; 

DISPOSE(temp); 

ELSE 

sectorsWrItten[nSectorsWritten] := nextSector; 
goToSector(nextSector); 

INC(nextSector); 

END; 

END brandNewSector; 

PROCEDURE goToSector(s-.Sector); 

(* We have to be careful here because the SetPosition function takes two 
16-bit CARDINALS, a high and a low; the actual file position is 
high*(2"16) + low, which can't be computed directly. So we calculate 

(In init) the number of sectors represented by a 1 in the high position, 
and work from there. The correctness of the formula depends on the 
sector size being a power of 2. 

If the place we're going to is beyond the end of the file, the file Is 
padded appropriately. 

*) 

VAR hi. lo. curHI, curLo:CARDINAL; 

bIanks:ARRAY[1..sectorsIze] OF CHAR; 

BEGIN 

hi :* s DIV sectorsPerHIgh; 

lo :* (s MOD sectorsPerHIgh)*sectorSize; 

GetFileLength(file, curHi, curLo); 

WHILE fcurHi < hi) OR ((curHi - hi) AND (curLo < lo)) DO 

(* file too short; pad it with a sector's worth of junk *) 

SetPosItion(fiIe, curHi, curLo); 

WriteBytes(file, ADR(blanks), sectorSize); 

GetFileLength(file, curHi, curLo); 

END; 

SetPos11ion(f11e, hi, lo); 

END goToSector; 

PROCEDURE freeSector(s.-Sector); 

(* Put the sector in sorted order In the list of free sectors. Keeping 

the list sorted should improve disk access time, since the head will only 
move In one direction (and possibly not at all) when the next sector is 
used. *) 

VAR 8 I, news IrSectorList; 

BEGIN 

NEW(news I); 

news I".sector :* s; 

IF (freeSectors ■ NIL) OR (freeSectors".sector >- s) THEN 
newsl".next :* freeSectors; 
freeSectors :* news I; 
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ELSE 

81 :* freeSectors; 

WHILE (sl^.next <> NIL) AND (sI~.next^.sector < s) DO 
sI :* sI*.next; 

END; 

news Inext :■ si*.next; 

8 I*.next :■ news I; 

END; 

END freeSector; 

PROCEDURE newDiskAddress(nSectors:CARDINAL):DiskAddress; 

VAR da:DiskAddress; 

BEGIN 

ALLOCATE(da, TSIZE(CARDINAL)+nSectors*TSIZE(Sector)); 
da*.size := nSectors; 

RETURN da; 

END newDiskAddress; 

PROCEDURE freeDlskAddress(VAR da:DiskAddress); 

BEGIN 

IF da <> NIL THEN 

DEALLOCATE(da, TSIZE(CARDINAL)+da*.size*TSIZE(Sector)); 
da NIL; 

END; 

END freeDiskAddress; 

PROCEDURE freeDiskStorage(VAR da:DiskAddress); 

VAR i:CARDINAL; 

BEGIN 

FOR ! :« 1 TO da*.size DO 
freeSector(da*.contents[1]); 

END; 

freeDiskAddress(da); 

END freeDiskStorage; 

PROCEDURE empty(da:DiskAddress):BOOLEAN; 

BEGIN 

RETURN da - nuI IDiskAddress; 

END empty; 

BEGIN 

nuIIDiskAddress NIL; 

END DisklO. 


readthis 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


Guide to the Source Code for BYTE's 
Spreadsheet Programming Project 


The spreadsheet program consists primarily of 8 modules: 


Calc (.MOD file only) 

Cel(List 

CommandProc 

DispIayHandIer 

Evaluator 

FormuI a 

ScreenHandler 

Spreadsheet.DEF 


Top-level module 

Lists of cells for dependency maintenance 
Command processor: reads and parses input 
In charge of the screen display 
Parses and evaluates formulas 
Maintains formula data structures 
Low-level interface to screen 

Definition of the spreadsheet abstract data type 


Corresponding to 


the Spreadsheet definition module are four 


impIementatIons: 


Implementation: 

Naive 

Dependency 

Sparse 

Virtual 


Modules used: 

Spreadsheet 1 
Spread8heet2 
Spreadsheet3, Celll 
Spreadsheet3, Cel 12, DisklO 


( continued ) 
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There is a single Cell definition module, used by both Cell 
Implementation modules. To use a particular Implementation, 
compile the necessary modules and rename the compiled code to 
omit the number. For instance, to use the sparse implementation, 
compile Spread3.M0D and Cel II.MOD, yielding Spreadsheet3.REL and 
Celll.REL (if you are using MacModula-2; the filename extensions 
may differ for other compilers). Then rename the REL files to 
Spreadsheet.REL and Cell.REL. Finally, link. 

Besides these modules, there are also some support modules: 

CharStuff 
Misc 

MyStoragel 
MyStorage2 
MyTermlnaI 
NumToString 
StringStuff 

The difference between MyStoragel and MyStorage2 is that the 
latter returns NIL when an allocation falls for lack of memory. 
This is very important for the virtual implementation of the 
spreadsheet. For testing purposes, MyStorage2 will pretend to 
run out of memory after only a few K bytes have been allocated. 
You will want to change this if you Intend to use the virtual 
implementation. 

A couple of machine-specific places in the code will need to be 
changed If you are not using a Macintosh. The ScreenHandIer 
module does some strange things to get around a bug in the 
Macintosh Quickdraw facility. And the DisklO module uses 
MacModula-2's FileSystem module, which is tailored to some extent 
to the Macintosh file system. You may need to make minor changes 
for your Implementation. 


spread3.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Spreadsheet; 

(* * This module Is used for both the sparse and virtual implementations. 

It depends on the module Cell (implementation module Cel II for sparse, 
Cel 12 for virtual). 

*) 


FROM Formula IMPORT formula, emptyFormuI a; 

IMPORT Formula; 

FROM Evaluator IMPORT evaIuateFormuI a; 

FROM Misc IMPORT fatal; 

FROM DispIayHandIer IMPORT displayCell; 

FROM Cel I List IMPORT cellList, cellRow, cellCol, nextCell, initFIndDep, 
nextDep, addToCelIList, removeFromCeIIList, nuIICeI IList, empty; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM Cell IMPORT cell, getCell, setCell, doForAIICeI Is, initSheet, clearSheet; 


CONST maxCard - 65535; (* Largest CARDINAL in this implementation *) 

VAR automatlc:BOOLEAN; 

PROCEDURE init; 

BEGIN 

automatic :■ TRUE; 
initSheet; 

END init; 

PROCEDURE cI earAI I; 

BEGIN 

clearSheet; 

END clearAII; 
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PROCEDURE setAutomatIc; 

BEGIN 

automatic :* TRUE; 

END setAutomatIc; 

PROCEDURE setManual; 

BEGIN 

automatic :* FALSE; 

END setManuaI; 

PROCEDURE inRange(row, coI;CARDINAL):BOOLEAN; 

BEGIN 

RETURN (row >- 1) AND (row <- maxRowH) AND 
(col >■ 1) AND (col <■ maxColiJi; 

END inRange; 

PROCEDURE setVaIue(row, coI:CARDINAL; value:REAL); 
VAR c:ceI I; ' 

BEGIN 

IF inRange(row, col) THEN 
getCelI(row, col, c); 

c.value :■ value; 
c.status :* OK; 
setCelI(row, col, c); 
operationStatus := OK; 
displayed I(row, col); 

IF automatic THEN 
recalc(row, col); 

END; 

ELSE 

operationStatus :■ RangeError; 

END; 

END setValue; 

PROCEDURE getVaIue(row, coI:CARDINAL):REAL; 

(* Get the value at row, col. *) 

VAR c;celI; 

BEGIN 

IF NOT inRange(row, col) THEN 
operationStatus RangeError; 

RETURN 0.0; 

ELSE 

getCelI(row, col, c); 

IF c.status <> OK THEN 
operationStatus :■ c.status; 

RETURN 0.0; 

ELSE 

operationStatus :« OK; 

RETURN c.value; 

END; 

END; 

END getValue; 

PROCEDURE setFormuIa(row, coI:CARDINAL; f:formula); 
VAR c:ceI I; 

BEGIN 

IF inRange(row, col) THEN 
freeDependencIes(row, col); 
getCelI(row, col, c); 

WITH c DO 
form :■ f; 
value :* 0.0; 
status :■ OK; 
setCelI(row, col, c); 

evaIuateFormuIa(form, row, col, value, status); 
setDependencles(row, col); 
dIspIayCeI I(row, col); 

IF automatic THEN 
recalc(row, col); 

END; 

END; 


( continued ) 
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operatlonStatus :• OK; 

ELSE 

operatlonStatus RangeError; 
END; 

END setFormula; 


PROCEDURE getFormu Ia(row, co I -.CARDINAL) : f ormu I a; 
VAR c:ceI I; 

BEGIN 

IF InRange(row, col) THEN 
operatlonStatus OK; 
getCelI(row, col, c); 

RETURN c.form; 

ELSE 

operatlonStatus :* RangeError; 

RETURN emptyFormula; 

END; 

END getFormula; 


PROCEDURE status(row, col:CARDINAL)rStatus; 

VAR c:ceI I; 

BEGIN 

IF lnRange(row, col) THEN 
getCelI(row, col, c); 
operatlonStatus :■ OK; 

RETURN c.status; 

ELSE 

operatlonStatus :■ RangeError; 

RETURN RangeError; 

END; 

END status; 

PROCEDURE maxRow():CARDINAL; 

BEGIN 

RETURN maxCard; 

END maxRow; 

PROCEDURE maxCoI():CARDINAL; 

BEGIN 

RETURN maxCard; 

END maxCoI; 

PROCEDURE recalculate; 

BEGIN 

doForAII Cells(evalCelI); 
operatIonStatus :■ OK; 

END recalculate; 

PROCEDURE evalCelI(row, coIiCARDINAL; VAR c:ceI I); 
VAR val:REAL; 

stat:Status; 

BEGIN 

WITH c DO 

IF (status <> Empty) AND (status <> SyntaxError) 
AND (NOT Formula.empty(form)) THEN 
evaluateFormula(form, row, col, val. stat); 

IF (stat <> status) OR (val <> value) THEN 
status :* stat; 

vaIue :« vaI; 
dlsplayCelI(row, col); 

END; 

END; 

END; 

END evalCelI; 

PROCEDURE recaIc(row, coI:CARDINAL); 

VAR val;REAL; 

stat:Status; 
c:ceI I; 

BEGIN 

getCelI(row, col, c); 

WITH c DO 
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IF (status <> Empty) AND (status <> SyntaxError) 

AND (NOT Formula.empty(form)) THEN 
evaIuateFormuIa(form, row, col, val, stat); 

IF (stat <> status) OR (val <> value) THEN 
status :* stat; 
value :« val; 
setCelI(row, col, c); 
displayCelI(row, col); 
recaIcDependents(c); 

END; 

ELSE 

recaIcDependents(c); 

END; 

END; 

END recalc; 

PROCEDURE recalcDependents(VAR c:cell); 

VAR cl reel ILIst; 

BEGIN 

cl : = c.dependentCeI 18; 

WHILE NOT empty(cl) DO 

recalc(celIRow(clceI ICo I(cI)); 
cl :* nextCelI(cl); 

END; 

END recaIcDependents; 

PROCEDURE setDependencies(row, coI:CARDINAL); 

VAR r, c:CARDINAL; 

cel:ce11; 

BEGIN 

getCelI(row, col, cel); 

IF cel.status <> SyntaxError THEN 
InitFIndDep(row, col, cel.form); 

WHILE nextDep(r, c) DO 
IF InRange(r, c) THEN 
getCelI(r, c, cel); 

addToCelI List(cel.dependentCeI Is, row, col); 
setCelI(r, c, cel); 

END; 

END; 

END; 

END setDependencles; 

PROCEDURE freeDependenc!es(row, coI:CARDINAL); 

VAR r, c:CARDINAL; 

ceI:ceI I; 

BEGIN 

getCell(row, col, cel); 

IF cel.status <> SyntaxError THEN 
In ItFIndDep(row, col, cel.form); 

WHILE nextDep(r, c) DO 
IF inRange(r, c) THEN 
getCell(r, c, cel); 

removeFromCelILIst(ceI.dependentCeI Is, row, col); 
setCelI(r, c, cel); 

END; 

END; 

END; 

END freeDependencles; 

PROCEDURE cI ear(row, coI:CARDINAL); 

BEGIN 

(* not Implemented *) 

END clear; 

BEGIN 

END Spreadsheet. 
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evaluat.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE Evaluator; 

FROM Spreadsheet IMPORT Status; 

FROM Formula IMPORT formula; 

EXPORT QUALIFIED evaIuateFormuI a, evaIuateStrIng, refexpr; 


PROCEDURE evaluateFormula(f:formula; row, col:CARDINAL; 

VAR v:REAL; VAR s:Status); 

PROCEDURE evaIuateStrIng(str:ARRAY OF CHAR; row, coI:CARDINAL; 

VAR v:REAL; VAR s:Status); 

PROCEDURE refexpr(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR v:REAL; VAR 8-.Status; addBase:CARDINAL) ; 


END Evaluator. 


displayh.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE D!spIayHand1er; 

FROM CommandProc IMPORT CommandType; 

EXPORT QUALIFIED wrItePrompt, moveCursor, setPrecIsIon, setColWIdth, 
dtsplayCell, dlspIayFormuI a, Inlt, setCorner, message; 

PROCEDURE wrItePrompt(row, coI:CARDINAL); 

PROCEDURE moveCursor(dIrectIon:CommandType):BOOLEAN; 

PROCEDURE setPrecIsIon(p:CARDINAL); 

(* * number of decimal places to be shown *) 

PROCEDURE setCo 1WIdth(cw:CARDINAL); 

PROCEDURE dlspIayCeI I(row, coI:CARDINAL); 

PROCEDURE dlspIayFormula(row, coI:CARDINAL); 

PROCEDURE setCorner(row, coI:CARDINAL); 

PROCEDURE Inlt; 

PROCEDURE message(s:ARRAY OF CHAR); 

END DlspIayHandIer. 


evaIuate.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Evaluator; 

(* Evaluator for the spreadsheet. 

*) 

(* grammar for formulas: ( \\ means "zero or more" ) 
<expr> <valexpr> | <valexpr> <relop> <valexpr> | 
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IF <expr> , <expr> , <expr> 

<valexpr> :<term> j <addop> <term> \ 

<term> :<factor>{ <mulop> <factor> { 

<factor> real | <cellref> | - <factor> | ( <expr> ) 

<cellref> :[ <refexpr> , <refexpr> ] 

<refexpr> :<addop> real | real 
<relop> ::■ < > | ■ | <> j >■ | <« 

<addop> ::* ♦ 

<mulop> : :* * / 

1 =« TRUE, 0 - FALSE. 

*) 

FROM Ml sc IMPORT fatal, assert; 

FROM Spreadsheet IMPORT maxRow, maxCol, Status, status, getValue; 

FROM StrlngStuff IMPORT strlng40, string160, strlngCopy, findChar; 

FROM CharStuff IMPORT isDigit, IsWhite; 

FROM ReaIConversIons IMPORT StrToReal, Rea IProcResponses, ReaIConversionRes; 

FROM Formula IMPORT formula; 

IMPORT Formula; 

FROM DispIayHandIer IMPORT message; 

FROM StringOps IMPORT Concat; 

TYPE 

relOpType * (Less, Greater, Equal, LessEqual, GreaterEquaI, NotEqual); 

VAR curRow, curCo I:CARDINAL; 

PROCEDURE evaIuateFormula(f:formula; row, coI:CARDINAL; VAR v:REAL; 

VAR s:Status); 

VAR str:strIng160; 

BEGIN 

Formu I a.toStrIng(f, str); 

evaIuateStr1ng(str, row, col, v, s); 

END evaIuateFormuI a; 

PROCEDURE evaluateStrfng(str:ARRAY OF CHAR; row, coIiCARDINAL; VAR v:REAL; 

VAR s:Status); 

VAR pos:CARDINAL; 

BEGIN 

pos :* 0; 

curRow row; 

curCoI :* col; 

expr(str, pos, v, s, TRUE); 

END evaluateString; 


(* <expr> <valexpr> <relop> <valexpr> | IF <expr> , <expr> , <expr> *) 
PROCEDURE expr(VAR str;ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR v:REAL; VAR s:Status; evaI:BOOLEAN); 

VAR v1:REAL; 

rop:relOpType; 

BEGIN 

IF nextChar(str, pos) THEN 

IF (str[pos] - T) AND (str[pos+1] - ’F*) THEN 
INC(pos. 2); 

ffexpr(str, pos, v, s, eval); 

ELSE 

valexpr(str, pos, v, s, eval); 

IF s - OK THEN 

IF nextChar(str, pos) THEN 
rel0p(8tr, pos, rop, s); 

IF s <> OK THEN (* shouldn't have looked at next char *) 
s OK; 

ELSE 

valexpr(etr, pos, vl, s, eval); 

IF s - OK THEN 

IF applyRelOp(rop, v, vl) THEN 
v :* 1.0; 

ELSE 

v ;■ 0.0; 


(continued ) 
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END; 

END; 

END; 

END; 

END; 

END; 

ELSE 

8 :* SyntaxError; 
error(str, pos); 

END; 

END expr; 

(* IF <expr> , <expr> , <expr> *) 

PROCEDURE Ifexpr(VAR str:ARRAY OF CHAR; VAR posCARDINAL; 

VAR v:REAL; VAR s:Status; evaI:BOOLEAN); 

(* ifexpr has to eval both branches, even though it knows the 

value of the test, because we do not separate parsing from evaluation. 
It doesn't cause a problem because there are no side-effects. *) 

VAR vTrue, vFalse;REAL; 

BEGIN 

expr(str, pos, v, s, eval); 

IF s - OK THEN 

IF (NOT nextChar(str, pos)) OR (str[pos] <> ’,') THEN 
s SyntaxError; 
error(8tr, pos); 

ELSE 

INC(pos); 

expr(8tr, pos, vTrue, s, v <> 0.0); 

IF s - OK THEN 

IF (NOT nextChar(str, pos)) OR (str[pos] <> ',') THEN 
s ;■ SyntaxError; 
error(str, pos); 

ELSE 

INC(pos); 

expr(str, pos, vFalse, s, v ■ 0.0); 

IF s - OK THEN 
IF v - 0.0 THEN 
v :■ vFaIse; 

ELSE 

v :■ vTrue; 

END; 

END; 

END; 

END; 

END; 

END; 

END ifexpr; 

PROCEDURE reIOp(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR rop:relOpType; VAR s:Status); 

BEGIN 

IF str[pos] - THEN 
rop :■ EquaI; 
s OK; 

INC(posj; 

ELSIF str[pos] - *>' THEN 
IF str[pos+1] - THEN 

rop :* GreaterEquaI; 

INC(pos, 2); 
s OK; 

ELSE 

rop :« Greater; 
s :« OK; 

INC(pos); 

END; 

ELSIF str[pos] « '<* THEN 
IF str[pos+1] = THEN 

rop :«■ LessEqua I ; 

INC(pos, 2); 
s OK; 

ELSE 

rop :» Less; 

INC(pos); 
s OK; 

END; 

ELSE 
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s :« SyntaxError; (* no message; this isn't a real error *) 
END; ' 

END relOp; 


PROCEDURE appIyReIOp(rop:relOpType; 
BEGIN 


▼ 1 • Y 4 • ixlML j < 


~ ~ ^ w Wf M ^ | 


CASE rop OF 
EquaI: 
NotEquaI: 
Less: 
Greater: 
LessEqual: 


RETURN vl * v2; 
RETURN v1 <> v2; 
RETURN vl < v2; 
RETURN vl > v2; 
RETURN vl <- v2; 


GreaterEqual: RETURN vl >= v2; 

ELSE 

fatal(*applyBoolOp: unknown op type'); 

END; 

END appIyReI Op; 


(* <vaIexpr> <term> } <addop> <term> { *) 

PROCEDURE vaIexpr(VAR str:ARRAY OF CHAR; VAR pos;CARDINAL; 

VAR v:REAL; VAR siStatus; evaI;BOOLEAN); 

VAR vliREAL; 

op:CHAR; 

BEGIN 

term(str, pos, v, s, eval); 

WHILE (s * OK) AND nextChar(str, pos) DO 
IF NOT addOp(str[pos]) THEN 
RETURN; 

END; 

op :* strfpos]; 

INC(pos); 

term(str, pos, vl, s, eval); 

IF (s - OK) AND eval THEN 
IF op - THEN 
v :■ v + vl; 

ELSE 

v :■ v - vl; 

END; 

END; 

END; 

END valexpr; 

(* <term> :<factor>{ <mulop> <factor> \ *) 

PROCEDURE term(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR v:REAL; VAR s:Status; eva I : BOOLEAN) ; 

VAR vl:REAL; 

op:CHAR; 

BEGIN 

factor(str, pos, v, s, eval); 

WHILE (s - OK) AND nextChar (str, pos) DO 
IF NOT mu I0p(8tr[pos]) THEN 
RETURN; 

END; 

op :■ strfpos]; 

INC(pos); 

factor(str, pos, vl, s, eval); 

IF (s - OK) AND eval THEN 
IF op - THEN 
v :■ v * vl; 

ELSIF vl = 0.0 THEN 
8 :« DivByZero; 

ELSE 

v v / vl; 

END; 

END; 

END; 

END term; 

(* <factor> ::- real | <cellref> | - <factor> | ( <expr> ) *) 

PROCEDURE factor(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR v:REAL; VAR s:Status; evaI:BOOLEAN); 


[continued] 
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BEGIN 

IF NOT naxtChar(str, pos) THEN 
9 :■ SyntaxError; 
arror(str, pos); 

ELSIF isDiglt (str[pos]) THEN 
parssRsaI(str, pos, v, s); 

ELSE 

INC(pos); 

CASE str[pos-1] OF 

• [•s cellRef(str, pos, v, s, aval); 

| factor(str, pos, v, s, aval); 

v -v; 

| axpr(str, pos, v, s, aval); 

IF s - OK THEN 

IF (NOT naxtChor(str, pos)) OR (strfpos] <> •)•) THEN 
s SyntaxError; 
arror(str, pos); 

ELSE 

INC(po8); 

END; 

END; 

ELSE 

s :■ SyntaxError; 
error(str, pos); 

END; 

END; 

END factor; 

(* <callraf> [ <rafaxpr> , <rafaxpr> ] 

Opanlng [ is alraady read. *) 

PROCEDURE caI IRaf(VAR str;ARRAY OF CHAR; VAR posiCARDINAL; 

VAR v;REAL; VAR s:Status; avaI:BOOLEAN); 

VAR vRow, vCol:REAL; 

r, c;CARDINAL; 

BEGIN 

rafaxpr(8tr, pos, vRow, s, curRow); 

IF s - OK THEN 

IF (NOT naxtChar(str, pos)) OR (strfpos] <> ',*) THEN 
8 SyntaxError; 
arror(str, pos); 

ELSE 

INC(pos); 

rafaxpr(str, pos, vCol, s, curCol); 

IF s - OK THEN 
IF aval THEN 

rangaChack(vRow, vCol, r, c, s); 

END; 

IF s - OK THEN 
IF aval THEN 

rafaranca(r, c, v, s); 

END; 

IF s - OK THEN 

IF naxtChar(str, pos) AND (strfpos] = *]*) THEN 
INC(pos); 

ELSE 

s SyntaxError; 
errorfstr, pos); 

END; 

END; 

END; 

END; 

END; 

END; 

END cal IRaf; 

(* <refexpr> <addop> raal | raal *) 

PROCEDURE rafaxpr(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; 

VAR v:REAL; VAR s:Status; addBasarCARDINAL); 

VAR op:CHAR; 

BEGIN 

IF NOT naxtChar(str, pos) THEN 
s :» SyntaxError; 
arror(str, pos); 

ELSE 

IF addOp(str[pos]) THEN 
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op :» str[pos]; 

INC(pos); 

ELSE 

op :■ 0C; 

END; 

IF NOT nextChar(str, pos) THEN 
s :■ SyntaxError; 
error(str, pos); 

ELSE 

parseReal(str, pos, v, s); 

IF s - OK THEN 
IF op - THEN 
v :■ FLOAT(addBase) + v; 
ELSIF op - THEN 

v :* FLOAT(addBase) - v; 
END; 

END; 

END; 

END; 

END refexpr; 


PROCEDURE addOp(c:CHAR):BOOLEAN; 
BEGIN 

RETURN (c - ’+’) OR (c - ’-•); 
END addOp; 

PROCEDURE mu I Op(c:CHAR):BOOLEAN; 
BEGIN 

RETURN (c - ’*’) OR (c * ’/’); 


END mu I Op; 


PROCEDURE rangeCheck(vRow, vCol:REAL; VAR r, c:CARDINAL; 
BEGIN 


(vRow >■ 1.0) 

AND 

(vRow 

<- FLOAT| 

JmaxRowQ)) 

(vCol >- 1.0) 

AND 

(vCol 

<- FLOAT( 

[maxCol())) 


r :« TRUNC(vRow); 
c TRUNC(vCol); 
ELSE 

s :« RangeError; 
END; 

END rangeCheck; 


VAR s:Status); 


PROCEDURE reference(row, coI:CARDINAL; VAR v:REAL; VAR s:Status); 
BEGIN ' 

IF status(row, col) - OK THEN 
v :* getValue(row, col); 
s OK; 

ELSE 

s :■ RefError; 

END; 

END reference; 


PROCEDURE parseReal(VAR str:ARRAY OF CHAR; VAR pos:CARDINAL; VAR v:REAL; 

VAR s:Status); 

VAR real,msg:strIng40; 

endPos CARDINAL; 

BEGIN 

skIpToEndOfReaI(str, pos, endPos); 
strIngCopy(reaI, str, pos, endPos); 

StrToReaI(reaI, v); 

CASE ReaIConverslonRes OF 
noError; s :* OK; 

| InvalldStr: s :■ SyntaxError; 

Concat(msg, "Invalid real; ", real); 
message(msg); 

| overflow: s Overflow; 

| underflow: s :■ Underflow; 

ELSE 

fataI("parseReaI: unknown error"); 

END; 

pos :■ endPos+1; 

END parseReal; 


(continued) 
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PROCEDURE sklpToEndOfReal(str:ARRAY OF CHAR; po«:CARDINAL;VAR endPos:CARDINAL); 
BEGIN 

endPos ;■ pos; 

WHILE (endPos <- HIGH(str)) AND 

findChar("0123456789E. M , str[endPos], pos) DO 
INC(endPos); 

END; 

DEC(endPos); 

END skIpToEndOfReoI; 


mytermin.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE MyTermlnal; 

(♦ Some small but useful additions to the Terminal module. * *) 

EXPORT QUALIFIED WrlteStrlng, WrlteLn, Write, Read, ClearScreen, Beep, 

WrlteLnString, Wrltelnt, WrlteCard, pause, spaces, places; 

PROCEDURE WrIteStrIng(s:ARRAY OF CHAR); 

PROCEDURE WrlteLn; 

PROCEDURE WrIte(c:CHAR); 

PROCEDURE Read(VAR c:CHAR); 

PROCEDURE ClearScreen; 

PROCEDURE Beep; 

PROCEDURE WrIteLnStrlng(s:ARRAY OF CHAR); 

PROCEDURE Wrltelnt(!:INTEGER; spaces:CARDINAL); 

PROCEDURE WrIteCard(c, spaces:CARDINAL); 

PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg Is typed out. *) 

PROCEDURE spaces(n:INTEGER); 

(* Prints n spaces, If n > 0. *) 

PROCEDURE pI aces(c:CARDINAL):CARDINAL; 

(* Returns the number of places It would take to print c. *) 

END MyTermlnaI. 


spread2.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Spreadsheet; 


The DEPENDENCY Implementation Is an array with dependency information: each 
cell knows which other cells depend on its value. In automatic mode, whenever 
a value Is changed the tree of dependencies is traversed depth-first, and 
the display handler is called for each changed value. 

*) 


FROM Formula IMPORT formula, emptyFormuI a; 

IMPORT Formula; 

FROM Evaluator IMPORT evaIuateFormuI a; 

FROM Mi sc IMPORT fatal; 

FROM DispIayHandIer IMPORT displayCell; 

FROM Cel IList IMPORT cellList, cellRow, cellCol, nextCell, initFindDep, 
nextDep, addToCeI IList, removeFromCeI IList, nuIICeI I List, empty; 
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CONST maxR - 32; 
maxC - 60; 

TYPE 

cell - RECORD 

value: REAL; 
form: formula; 
status: Status; 
dependentCeI Is: cel Hist; 
END; 


VAR sheet: ARRAY[1..maxR], [l..maxC] OF cell; 
automatlc:BOOLEAN; 

PROCEDURE Inlt; 

VAR row, coI:CARDINAL; 

BEGIN 

automatic :■ TRUE; 

FOR row :■ 1 TO maxR DO 
FOR col :* 1 TO maxC DO 
WITH sheet[row, col] DO 
status :« Empty; 
form :■ emptyFormuI a; 
dependentCeI Is :« nuIICeI IList; 

END; 

END; 

END; 

END init; 

PROCEDURE clearAII; 

VAR row, col-.CARDINAL; 

BEGIN 

FOR row :■ 1 TO maxR DO 
FOR col :■ 1 TO maxC DO 
WITH sheet[row, col] DO 

status :• Empty; 

Formula.free(form); 
form :■ emptyFormula; 

END; 

END; 

END; 

END cIearAII; 

PROCEDURE setAutomatIc; 

BEGIN 

automatic :* TRUE; 

END setAutomatIc; 

PROCEDURE setManual; 

BEGIN 

automatic := FALSE; 

END setManuaI; 

PROCEDURE InRange(row, coI:CARDINAL):BOOLEAN; 

BEGIN 

RETURN (row >« 1) AND (row <• maxR) AND (col >= 1) AND (col <« maxC); 
END InRange; 

PROCEDURE setValue(row, coI CARDINAL; vaIue:REAL); 

BEGIN 

IF InRange(row, col) THEN 

sheetfrow, col].value :« value; 
sheetfrow, col].status :■ OK; 
operatlonStatus :■ OK; 
dlsplayCelI(row, col); 

IF automatic THEN 

recalc(row, col); 

END; 

ELSE 

operatlonStatus :■ RangeError; 

END; 

END setValue; 


[continued] 
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PROCEDURE gatVolu*(row, col:CARDINAL):REAL; 

(* Get the value at row, col. *) 

BEGIN 

IF NOT InRange(row, col) THEN 

operatlonStatus :■ RangeError; 

RETURN 0.0; 

ELSIF 8heet[row, col].status <> OK THEN 

operatlonStatus sheet[row, col].status; 
RETURN 0.0; 

ELSE 

operatlonStatus :■ OK; 

RETURN sheet[row, col].value; 

END; 

END getValue; 

PROCEDURE setFormula(row, co I-.CARDINAL; f-.formula); 
BEGIN 

IF lnRange(row, col) THEN 
freeDependenc!es(row, col); 

WITH sheet[row, col] DO 
form f; 
vaIue :■ 0.0; 
status ;■ OK; 

evaIuateFormuIa(form, row, col, value, status); 
setDependencles(row, col); 
dlsplayCelI(row, col); 

IF automatic THEN 
recalc(row, col); 

END; 

END; 

operatlonStatus :« OK; 

ELSE 

operat lonStatus :=* RangeError; 

END; 

END setFormula; 

PROCEDURE getFormuIa(row, coI:CARDINAL):formuI a; 

BEGIN 

IF lnRange(row, col) THEN 
operatlonStatus :■ OK; 

RETURN sheet[row, col].form; 

ELSE 

operatlonStatus :■ RangeError; 

RETURN emptyFormuI a; 

END; 

END getFormula; 


PROCEDURE cl ear(row, coI:CARDINAL); 
BEGIN 


IF inRange(row, col 
sheetTrow, col' 
sheet row, col 
sheet[row, col 


ELSE 


operatlonStatus 


) THEN 

.status := Empty; 

.form :« emptyFormuI a; 
.dependentCeI Is := nuIICeI ILIst; 
:= OK; 


operationStatus :■ RangeError; 

END; 

END clear; 


PROCEDURE status(row, coI:CARDINAL):Status; 
BEGIN 

IF !nRange(row, col) THEN 
operatlonStatus :« OK; 

RETURN sheet[row, col].status; 

ELSE 

operatIonStatus :* RangeError; 
RETURN RangeError; 

END; 

END status; 

PROCEDURE maxRow()iCARDINAL; 

BEGIN 

RETURN maxR; 

END maxRow; 
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PROCEDURE maxCoI():CARDINAL; 

BEGIN 

RETURN maxC; 

END maxCoI; 

PROCEDURE recalculate; 

VAR row, coI:CARDINAL; 
val:REAL; 
stat:Status; 

BEGIN 

FOR row :■ 1 TO maxR DO 
FOR col :* 1 TO maxC DO 
WITH sheet[row, col] DO 

IF (status <> Empty) AND (status <> SyntaxError) 
AND (NOT Formula.empty(form)) THEN 
evaluateFormula(form, row, col, val, stat); 

IF (stat <> status) OR (val <> value) THEN 
status :* stat; 
value :* val; 
displayCelI(row, col); 

END; 

END; 

END; 

END; 

END; 

operatlonStatus :« OK; 

END recalculate; 

PROCEDURE recaIc(row, coI:CARDINAL); 

VAR val .-REAL; 
stat:Status; 
cl:ceIIL1st; 

BEGIN 

WITH sheet[row, col] DO 

IF (status <> Empty) AND (status <> SyntaxError) 

AND (NOT FormuI a.empty(form)) THEN 
evaIuateFormuIa(form, row, col, val, stat); 

IF (stat <> status) OR (val <> value) THEN 
status :« stat; 
vaIue vaI; 
displayCelI(row, col); 
recaIcDependents(sheet[row, col]); 

END; 

ELSE 

recaIcDependents(sheet[row, col]); 

END; 

END; 

END recalc; 


PROCEDURE recaIcDependents(VAR c:cell); 

VAR cl reelIList; 

BEGIN 

cl :* c.dependentCeI Is; 

WHILE NOT empty(cl) DO 

recalc(celIRowfcl), ceI I Co I(cI)); 
cl :■ nextCelI(cl); 

END; 

END recalcDependents; 

PROCEDURE setDependencies(row, coI;CARDINAL); 

VAR r, c:CARDINAL; 

BEGIN 

IF sheetfrow, col].status <> SyntaxError THEN 
inltF!ndDep(row, col, sheet[row, col].form); 

WHILE nextDep(r, c) DO 
IF lnRange(r, c) THEN 

addToCelILIst(sheet[r, c].dependentCeI Is, row, col); 
END; 

END; 

END; 

END setDependencIes; 


(continued) 
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PROCEDURE freeDependencies(row, coI:CARDINAL); 

VAR r, c:CARDINAL; 

BEGIN 

IF sheet[row, col].status <> SyntaxError THEN 
InitFlndDep(row, col, sheet[row, col],form); 

WHILE nextDep(r, c) DO 
IF inRange(r, c) THEN 

removeFromCeIILIst(sheet[r, c]. dependentCeMs, row, col); 
END; 

END; 

END; 

END freeDependsncI as; 

BEGIN 

END Spreadsheet. 


dispIayh.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE DispIayHandIer; 

(* Top row of screen is for display of messages; 2nd, of formulas; 3nd row 
is for entry; rest Is spreadsheet. *) 

FROM CommandProc IMPORT CommandType; 

FROM MyTermlnal IMPORT WrlteCard, ClearScreen, Beep; 

IMPORT Formula; 

FROM Spreadsheet IMPORT getValue, getFormula, InRange, status, Status; 

FROM StrlngStuff IMPORT strlngLen, $trIngAssIgn, strlng80, string40; 

FROM Misc IMPORT fatal, min; 

FROM NumToStrlng IMPORT cardToStrIng, reaIToStrIng; 

FROM ScreenHandIer IMPORT setCursorPos, Write, WrlteStrlng; 

IMPORT ScreenHandIer; 

CONST 

messageRow « 0; 
messageCol ■ 0; 
formuIaDispIayRow ■ 1; 
formulaDisplayCol - 0; 
promptRow « 2; 
promptCol * 0; 
colNumberRow ■ 3; 
colNumberCol » 4; 
rowNumberRow * 5; 
rowNumberCol * 0; 
cornerRow * 5; 
cornerCol = 4; 
initial Co IWId t h « 6; 
maxColWldth - 25; 
minColWidth - 1; 
inltiaIPrecision * 2; 
maxPrecision ■ 6; 
mInPrecision - 0; 
maxScreenRow ■ 20; 
maxScreenCol ■ 70; 

VAR celICursorRow, ceIICursorCoI, cornerCeI I Row, cornerCeIICoI, 
precision, colWidth, lastRow, lastCol:CARDINAL; 

PROCEDURE Inlt; 

BEGIN 

cornerCeIIRow :■ 1; 
cornerCeIICoI :* 1; 
ceIICursorRow :« cornerCeI I Row; 
ceIICursorCoI :■ cornerCeIICoI; 
precision :« initia IPrecision; 
colWidth initiaICoIWidth; 

ScreenHandIer.Init; 
redispI ay; 

END inlt; 
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PROCEDURE writePrompt(row, coI:CARDINAL); 

BEGIN 

cIearToEOL(promptRow, promptCol); 

Write('['); 

Wr i teCard(row, 0); Wrlte(','); Wr 1 teCard(co I , 0); 
Wr IteStrIng("]: "); 

END writePrompt; 

PROCEDURE message(s:ARRAY OF CHAR); 

BEGIN 

cIearToEOL(messageRow, messageCoI); 
WriteString(s); 

END message; 


PROCEDURE moveCursor(dlrectioniCommandType):BOOLEAN; 
BEGIN 

CASE direction OF 

Up; IF ceIICursorRow > cornerCeI I Row THEN 
DEC(celICursorRow); 
displayCelICursor; 

RETURN TRUE; 

ELSE 


| Down: 


| Left: 


I Right; 


ELSE 

fatal( 


Beep; 

END; 

IF ceIICursorRow < lastRow THEN 
INC(ceIICursorRow); 
dispIayCeIICursor; 

RETURN TRUE; 

ELSE 

Beep; 

END; 

IF celICursorCol > cornerCeIICoI THEN 
DEC(ceIICursorCoI); 
dispIayCeIICursor; 

RETURN TRUE; 

ELSE 

Beep; 

END; 

IF celICursorCol < lastCol THEN 
INC(ceIICursorCoI); 
dIspIayCeIICursor; 

RETURN TRUE; 

ELSE 

Beep; 

END; 

moveCursor; unknown direction'); 


END; 

RETURN FALSE; 

END moveCursor; 

PROCEDURE displayCelICursor; 
BEGIN 

(* do nothing for now *) 
END dIspIayCeIICursor; 


PROCEDURE setPrecIsIon(p:CARDINAL); 

(* number of decimal places to be shown *) 

BEGIN 

IF (p < minPrecisIon) OR (p > maxPrecision) THEN 
me8sage("IIlegal precision"); 

ELSE 

precision :■ p; 
displayCelIs; 

END; 

END setPrecision; 

PROCEDURE s e t Co IWId t h(cw:CARDINAL); 

BEGIN 

IF (cw < minColWidth) OR (cw > maxColWidth) THEN 
message("II legal column width"); 

ELSE 

coI Width cw+1; 
redisplay; 

I continued) 
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END; 

END setCoI Width; 


PROCEDURE setCorner(row, 
BEGIN 

IF InRange(row, col) 
cornarCelIRow :■ 
cornerCelICol 
celICursorRow :■ 
calICursorCol 
redispI ay; 

ELSE 


col:CARDINAL); 

THEN 
row; 
col; 
row; 
col; 


message("CeI I out of ronga"); 

END; 

END setCornar; 


PROCEDURE dlsplayFormula(row, coI:CARDINAL); 

BEGIN 

cIaarToEOL(formuIaDIspIayRow, formu IaDispIayCoI); 

Formula.wrlte(getFormula(row, col)); 

END dIspIayFormuI a; 

PROCEDURE dlsplayCalI(row, coI:CARDINAL); 

VAR dummy:BOOLEAN; 

BEGIN 

dummy :■ dIspCaI I(row, col); 

END dlsployCelI; 

PROCEDURE dlspCalI(row, coI:CARDINAL):BOOLEAN; 

(* Returns TRUE If It actually displays the call *) 

VAR screenRow, screenCoI:CARDINAL; 

BEGIN 

IF (row >- cornarCelIRow) AND (col >* cornarCaIICoI) THEN 
screenRow :■ (row - cornarCaI I Row) + cornerRow; 
screenCoI (col - cornarCaIICoI)*coIWldth + cornerCol; 

IF (screenRow <« maxScreenRow) AND (screenCol <* maxScreenCoI) THEN 
satCursorPos(screenRow, screenCoI); 

Wr I te (*|*)5 

dispIayVaIue(row, col, mTn(maxScreenCo1-screenCo 1 + 1 , coIWldth- 1 )); 
RETURN TRUE; 

END; 

END; 

RETURN FALSE; 

END dispCelI; 

PROCEDURE displayValue(row, col, spacerCARDINAL); 

VAR strlng:strlng40; 

I, I an rCARDINAL; 

BEGIN 

IF space > 0 THEN 

valToStrIng(row, col, string); 
len strIngLen(string); 

IF len >- space THEN 
FOR I := 0 TO space-1 DO 
Wrlte(strlng[I]); 

END; 

ELSE 

spaces(space-len); 

IF len <> 0 THEN 

FOR I 0 TO len-1 DO 
Wr I te(strIng[I]); 

END; 

END; 

END; 

END; 

END dIspIayVaIue; 

PROCEDURE valToStr ing(row, co I-.CARDINAL; VAR string:ARRAY OF CHAR); 

BEGIN 

CASE 8 tatu 8 (row, col) OF 

OK: realToString(getVaIue(row, col), precision, string); 
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Empty: strlng[0] :■ 0C; 

DivByZero: str1ngAssign(strIng, "?DIV"); 
RefError: strIngAssIgnfstring, M ?REF "); 

RangeError: stringAssign(string, M ?RNG"); 
Overflow: strIngAssignfstrIng, "?OVF"); 

Underflow: strIngAssIgn(strIng, "?UNF"); 
SyntoxError: stringAssIgn(string, "?SYN"); 

ELSE 


strIngAssign(strIng, "???"); 

END; 

END valToString; 


PROCEDURE redisplay; 

VAR row, coI:CARDINAL; 

BEGIN 

ClearScreen; 
dlspIayCoI Numbers; 
dlspIayRowNumbers; 
displayCelIs; 

END redisplay; 

PROCEDURE displayCelIs; 

VAR row, coI:CARDINAL; 

BEGIN 

row :■ cornerCeIIRow; 
col :* cornerCeIICol; 

WHILE dispCeI I(row, col) DO 
REPEAT 

INC(col); 

UNTIL NOT dlspCeI I(row, col); 
lastCol :■ col-1; 

INC(row); 

col :■ cornerCelICol; 

END; 

lastRow :» row-1; 

END displayCelIs; 

PROCEDURE dispIayCo(Numbers; 

VAR s:string80; 

screenCol, celICol, space, i:CARDINAL; 

BEGIN 

setCursorPos(coI NumberRow, colNumberCol); 
screenCol :■ colNumberCol; 
celICol :■ cornerCelICol; 

WHILE screenCol <* maxScreenCol DO 
Wr!te(’|’); 

cardToStrIngfceIICoI, s); 
centerStrlng(s, coI Width-1); 

space :- min(maxScreenCo1-screenCoI, colWidth-1); 
IF space <> 0 THEN 
FOR I :■ 0 TO space-1 DO 
carefulWrite(s, l); 

END; 

END; 

INCfscreenCoI, space+1); 

INC(celICol); 

END; 

setCursorPos(colNumberRow+1, 0); 

FOR I :■ 0 TO maxScreenCol DO 
WrIte(*-*); 

END; 

END displayColNumbers; 

PROCEDURE dispIayRowNumbers; 

VAR s:strlng40; 

•creenRow, celIRow, I, upperLImlt:CARDINAL; 

BEGIN 

screenRow :■ rowNumberRow; 

celIRow :■ cornerCeIIRow; 

upperLImit :■ cornerCo1-rowNumberCo1-2; 

WHILE screenRow <■ maxScreenRow DO 
cardToStrlngfceIIRow, s); 
setCursorPos(screenRow, rowNumberCoI); 

FOR I 0 TO upperLimit DO 
carefulWrIte(e, I); 


(continued) 
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END; 

INC(screenRow); 

INC(celI Row); 

END; 

END displayRowNumbers; 

(*** utilities ***) 

PROCEDURE centerStrIng(VAR s:ARRAY OF CHAR; space CARDINAL); 

(* center the string In the given space, padding the left with blanks *) 
VAR spaceCount, I, Ien;CARDINAL; 

BEGIN 

len :■ strIngLen(s); 

IF len < space THEN 

spaceCount :■ (space - len) DIV 2; 

IF spaceCount <> 0 THEN 
FOR i :• len TO 0 BY -1 DO 
s[i+spaceCount] :* s[i]; 

END; 

FOR I :* 0 TO spaceCount-1 DO 
s[l] 

END; 

END; 

END; 

END centerString; 

PROCEDURE carefuIWrite(VAR s:ARRAY OF CHAR; I;CARDINAL); 

BEGIN 

IF I >■ stringLen(s) THEN 
WriteO *); 

ELSE 

Wr 11e(8[I]); 

END; 

END carefulWrite; 


PROCEDURE clearToEOL(row, coI:CARDINAL); 
BEGIN 

setCursorPo 8 (row, col); 
spaces(maxScreenCoI - col + 1 ); 
setCursorPo 8 (row, col); 

END clearToEOL; 

PROCEDURE spaces(n:CARDINAL); 

BEGIN 

WHILE n > 0 DO 
Wrlte(' ’); 

DEC(n); 

END; 

END spaces; 

BEGIN 

END DisplayHandler. 


screenha.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE ScreenHandIer; 

FROM QuickDrawl IMPORT TextMode, srcOr, GetPen, DrawText, QDPtr, Rect, 
DrawChar, Point, MoveTo, Move, Fontlnfo, GetFontlnfo, EraseRect, 
SetRect, TextWidth, CharWidth; 

FROM StringOps IMPORT Length; 

FROM SYSTEM IMPORT ADR; 

VAR charWidth, charHeight, charAscent, charDescent:INTEGER; 

PROCEDURE init; 

(* Sets up for current font *) 

VAR lnfo:FontInfo; 
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BEGIN 

TextMode(srcOr); 

GatFontInfo(info); 

WITH Info DO 

charWidth :« widMax; 

charHeight :« ascent + descent + leading; 
charAscent :« ascent; 
charDescent :■ descent; 

END; 

END Init; 

PROCEDURE setCursorPos(row, coI:CARDINAL); (* zero-based *) 

BEGIN 

MoveTo(VAL(INTEGER, coI)*charWidth, VAL(INTEGER, (row+1))*charHeight); 
END setCursorPos; 

PROCEDURE getCursorPos(VAR row, coI:CARDINAL); 

VAR p:Point; 

BEGIN 

GetPen(p); 

row :« (p.v DIV charHeight)-1; 
col :» p.h DIV charWidth; 

END getCursorPos; 

PROCEDURE WrIte(ch:CHAR); 

BEGIN 

erase(0, charAscent, charWidth, -charDescent); 

DrawChar(ch); 

END Write; 

PROCEDURE WriteString(s:ARRAY OF CHAR); 

VAR Ien:INTEGER; 

BEGIN 

len VAL(INTEGER, Length(s)); 

erase(0, charAscent, TextWidth(QDPtr(ADR(s)), 0, len), -charDescent); 
DrawText(QDPtr(ADR(s)), 0, len); 

END WriteStrIng; 

PROCEDURE erase(left, top, right, bottom:INTEGER); 

VAR penPos:Point; 

bIankRect:Rect; 

BEGIN 


GetPen(penPos); 

SetRect(blankRect, penPos.h + left, penPos.v - top, 

? enPos.h + right, penPos.v - bottom); 

; 

END erase; 


BEGIN 

END ScreenHandler. 


mytermin.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE MyTerminal; 

(* Some small but useful additions to the Terminal module. *) 
IMPORT Terminal; 

VAR powerOfTen: ARRAY[0..4] OF CARDINAL; 


PROCEDURE WrIteLnStrIng(t:ARRAY OF CHAR); 
BEGIN 

Terminal.WrIteString(s); 

TerminaI.WriteLn; 

END WriteLnStrlng; 


( continued) 
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PROCEDURE Wrltelnt(l:INTEGER; spaces:CARDINAL): 

BEGIN ' 

IF I < 0 THEN 

IF spaces <> 0 THEN 

wrIteNum(CARDINAL(-l), spaces-1, TRUE); 

ELSE 

wrIteNum(CARDINAL(-i), 0, TRUE); 

END; 

ELSE 

END wr,teNum ( CARDINAL ( f )» spaces, FALSE); 

END Writelnt; 

PROCEDURE WrIteCard(c, spaces:CARDINAL); 

BEGIN 

wrIteNum(c, spaces, FALSE); 

END WrlteCard; 

PROCEDURE wrIteNum(c, spaces:CARDINAL; neg:BOOLEAN); 

VAR p:CARDINAL; 

i:INTEGER; 

BEGIN 

p :« places(c); 

FOR I 1 TO INTEGER(spaces) - INTEGER(p) DO 
Terminal.Wr!te(' •); 

END; 

IF neg THEN 

Terminal.Write( , - f ); 

END; 

FOR I p-1 TO 0 BY -1 DO 

Terminal.Write(CHR((c DIV powerOfTenfi]) + ORDf’0’))): 
c :■ c MOD powerOfTenfi]; 

END; 

END writeNum; 


PROCEDURE pI ace s(c:CARDINAL):CARDINAL; 

(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)) 
VAR I:CARDINAL; N 

BEGIN 

FOR I ;■ 4 TO 0 BY -1 DO 


*) 


IF (c DIV powerOfTenfI]) > 0 THEN 
RETURN 1+1; 

END; 

END; 

RETURN 1; 

END places; 


PROCEDURE pause(msg:ARRAY OF CHAR); 

(* Prevents the screen from blanking and returning to the Finder until the 
user hits a key. msg is typed out. *) 

VAR ch:CHAR; 

BEGIN 

Terminal.WrlteStrlng(msg); 

TerminaI.Read(ch); 

END pause; 

PROCEDURE spaces(n;INTEGER); 

VAR i:INTEGER; 

BEGIN 

FOR l :« 1 TO n DO 

Terminal.WrIte(’ ’); 

END; 

END spaces; 


(*** Copies of Terminal procedures ***) 

PROCEDURE Wr!teString(s:ARRAY OF CHAR); 

BEGIN 

TerminaI.WriteString(s); 

END WrlteStrtng; 

PROCEDURE WrlteLn; 

BEGIN 
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TerminaI.Wr1teLn; 

END WrlteLn; 

PROCEDURE Write(ciCHAR); 
BEGIN 

TerminaI.WrIte(c); 

END Write; 

PROCEDURE Read(VAR c:CHAR); 
BEGIN 

TerminaI.Read(c); 

END Read; 

PROCEDURE ClearScreen; 

BEGIN 

Terminal.ClearScreen; 
END ClearScreen; 

PROCEDURE Beep; 

BEGIN 

Terminal.Beep; 

END Beep; 

BEGIN 


powerOfTen 

*0' 

1; 

powerOfTen 

Y 

:* 10; 

powerOfTen 

Y 

100; 

powerOfTen 

’3' 

:« 1000; 

powerOfTen 

V 

:* 10000; 


END MyTerminal. 


charstuf.def 

Programming Project: "Build a Spreadsheet Program/' by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE CharStuff; 

(* Useful functions for manipulating characters. *) 

EXPORT QUALIFIED TAB, EOF, getChar, ungetChar, toUpper, toLower, toString, 
IsAlphaNum, isLetter, isUpper, isLower, IsDigit, isWhlte; 

CONST TAB - 11C; 

EOF ■ 0C; (* end of file *) 

(* getChar and ungetChar use InOut’s Read procedure but allow you to push 
a character back on the Input. Only one character at a time can be 
ungotten. getChar returns EOF on end of file. *) 

PROCEDURE getChar():CHAR; 

PROCEDURE ungetChar; 

(* These next few are useful for classifying characters. *) 

PROCEDURE IsAIphaNum(c:CHAR):BOOLEAN; 

PROCEDURE IsLe11 e r(c:CHAR):BOOLEAN; 

PROCEDURE IsUpper(c:CHAR):BOOLEAN; 

PROCEDURE IsLowe r fc:CHAR):BOOLEAN; 

PROCEDURE isDlgIt(c:CHAR):BOOLEAN; 

PROCEDURE IsWhIte(c:CHAR):BOOLEAN; (* space, tab or newline (EOL) *) 


(* This converts a lower-case character to upper-case, or does nothing If 
the character isn't a lower-case character. The same procedure is 
available In module StrlngStuff under the name charCap. *) 

PROCEDURE toUpper(c:CHAR):CHAR; 

PROCEDURE toLower(c:CHAR):CHAR; 


(continued) 
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PROCEDURE toStrlng(c:CHAR; VAR s:ARRAY OF CHAR); 

(* Converts the character c Into a string. This procedure won’t be needed 
for the new Modula-2 standard, because a single character will be 
compatible with a string. *) 

END CharStuff. 


charstuf.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE CharStuff; 

FROM InOut IMPORT Read, EOL, WriteStrlng; 

VAR ch:CHAR; 

ungotten:BOOLEAN; 

PROCEDURE getChar():CHAR; 

BEGIN 

IF ungotten THEN 

ungotten :« FALSE; 

ELSE 

Read(ch); 

END; 

RETURN ch; 

END getChar; 

PROCEDURE ungetChar; 

BEGIN 

IF ungotten THEN 

WrlteStrlng("ungetChar: can only unget one character at a time"); 
HALT; ' 

ELSE 

ungotten :« TRUE; 

END; 

END ungetChar; 


PROCEDURE lsAIphaNum(c:CHAR):BOOLEAN; 

BEGIN 

RETURN isLetter(c) OR IsDlglt(c); 

END IsAlphaNum; 

PROCEDURE IsLe11 e r(c:CHAR):BOOLEAN; 

BEGIN 

RETURN IsUpper(c) OR isLower(c); 

END IsLetter; 

PROCEDURE isUpper(c:CHAR):BOOLEAN; 

BEGIN 

RETURN (c >- •A*) AND (c <- ’Z’); 

END isUpper; 

PROCEDURE i8 Lowe r(c:CHAR):BOOLEAN; 

BEGIN 

RETURN (c >- ’a’) AND (c <« * 2 '); 

END IsLower; 

PROCEDURE isDiglt(c:CHAR):BOOLEAN; 

BEGIN 

RETURN (c >- *0*) AND (c <« ’9’); 

END IsDiglt; 

PROCEDURE isWh11 e(c:CHAR):BOOLEAN; 

BEGIN 

RETURN (c * * •) OR (c « TAB) OR (c = EOL); 
END IsWhite; 

PROCEDURE toUpper(c:CHAR):CHAR; 

BEGIN 

IF IsLower(c) THEN 
RETURN CAP(c); 
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ELSE 

RETURN c; 

END; 

END toUpper; 

PROCEDURE toLower(c:CHAR):CHAR; 

BEGIN 

IF isUpper(c) THEN 

RETURN CHR(ORD(c) - ORD(’A’) + ORD(*a*)); 

ELSE 

RETURN c; 

END; 

END toLower; 

PROCEDURE toString(c:CHAR; VAR s:ARRAY OF CHAR); 
BEGIN 


S l I J . “ , 

END toString; 

BEGIN 

ungotten :■ FALSE; 
END CharStuff. 


spread.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE Spreadsheet; 

(* Defines the spreadsheet data type. There are a variety of implementations: 

The DUMB implementation is Just an array. In automatic mode, every time a 
value is set, It recalculates the whole spreadsheet. It calls the display 
handler to redraw those cells which have changed. 

The DEPENDENCY implementation is an array with dependency information: each 
cell knows which other cells depend on Its value. In automatic mode, whenever 
a value Is changed the tree of dependencies is traversed depth-first, and 
the display handler Is called for each changed value. 

The SPARSE DEPENDENCY implementation is like the dependency, but uses a sparse 
array of blocks of cells Instead of a real array. 

The VIRTUAL SPARSE DEPENDENCY implementation is like the sparse dependency, 
but will write blocks of cells to the disk when memory is full, and swap them 
in as needed. 

*) 

FROM Formula IMPORT formula; 


EXPORT QUALIFIED setValue, getValue, setFormula, getFormula, status, 

Status, maxRow, maxCol, setAutomatIc, setManual, recalculate. 
Init, InRange, operationStatus, clearAII; 

TYPE Status - (OK, Empty. DivByZero, Overflow, Underflow, 

RefError, RangeError. SyntaxError); 

VAR operat ionStatus: Status; , a ^ t _ 

(* Spreadsheet operations (like setValue, etc.) will set this to OK if 
success, otherwise to an error status, usually RangeError. *) 

PROCEDURE init; 

PROCEDURE setVaIue(row, col:CARDINAL; vaIue:REAL); 

(* Sets the value of the cell at row, col. If automatic recalculation is 
turned on, this will result in a recalc, operationStatus - RangeError 
If row, col Is out of range. *) 


{continued) 
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PROCEDURE getVaIue(row, coI:CARDINAL):REAL; 

(* Get the value at row, col. Returns 0.0 and sets operatlonStatus to 
RangeError If out of range. *) 

PROCEDURE setFormuIa(row, col:CARDINAL; f:formula); 

(* Sets the formula. Computes the value for the cell and displays it 
operatlonStatus ■ RangeError If row, col out of range. *) 

PROCEDURE getFormulo(row, col:CARDINAL):formula; 

(* Returns the formula, operatlonStatus - RangeError If out of range. *) 
PROCEDURE cleorAII; 

(* Clears all the spreadsheet’s cells. «) 

PROCEDURE 8tatus(row, col:CARDINAL):Status; 

(* Returns the cell's status. Con set operationStotus to RangeError. *) 
PROCEDURE maxRow():CARDINAL; 

(* Returns the maximum row value for the spreadsheet. *) 

PROCEDURE maxCol():CARDINAL; 

(* Returns the maximum column value for the spreadsheet. *) 

PROCEDURE satAutomatlc; 

(* Sets recalc mode to automatic. *) 

PROCEDURE setManual; 

(* Sets recalc mode to manual. *) 

PROCEDURE recalculate; 

(* Recalculates the spreadsheet. Any cell which changes Is redisplayed. *) 
PROCEDURE lnRonge(row, col:CARDINAL):BOOLEAN; 

(* Returns TRUE If row, col ore within the bounds of the spreadsheet 
(row between 1 and maxRow, column between 1 and maxCol). *) 

END Spreadsheet. 


stringst.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE StrlngStuff; 

EXPORT QUALIFIED string40, string80, strlng160, string255, 
strlngCap, charCap, stringLen, strlngCopy, stringEqual. 
deleteChar, findChar, stringAssign, insertChar; 

TYPE 

strIng40 - ARRAY[0..40l OF CHAR; 
string80 - ARRAY[0..80J OF CHAR; 
strlng160 - ARRAY[0..160] OF CHAR; 
str!ng255 - ARRAY[0..255] OF CHAR; 

PROCEDURE chorCap(ch:CHAR):CHAR; 

PROCEDURE stringCap(VAR s:ARRAY OF CHAR); 

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL; 

PROCEDURE stringAssIgn(VAR dest:ARRAY OF CHAR; source:ARRAY OF CHAR); 
PROCEDURE stringCopy(VAR dest. source:ARRAY OF CHAR; from, to:CARDINAL); 
PROCEDURE stringEqual(si. s2:ARRAY OF CHAR):BOOLEAN; 

PROCEDURE deleteChar(VAR s:ARRAY OF CHAR; pos:CARDINAL); 

PROCEDURE insertChar(ch:CHAR; VAR s:ARRAY OF CHAR; posCARDINAL); 
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PROCEDURE flndChar(s:ARRAY OF CHAR; ch:CHAR; VAR pos:CARDINAL):BOOLEAN; 
END StrIngStuff. 


July 


spreadl.mod 

Programming Project: "Build a Spreadsheet Program." by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Spreadsheet; 

(* Defines the spreadsheet data type. There are a variety of implementations: 

The DUMB implementation is just an array. In automatic mode, every time a 
value is set, it recalculates the whole spreadsheet. It calls the display 
handler to redraw those cells which have changed. 

*) 

FROM Formula IMPORT formula, emptyFormula; 

IMPORT Formula; 

FROM Evaluator IMPORT evaIuateFormuI a; 

FROM Mi sc IMPORT fatal; 

FROM DisplayHandler IMPORT displayCell; 


CONST maxR * 32; 
maxC = 60; 

TYPE cell - RECORD 

value: REAL; 
form: formula; 
status: Status; 

END; 

VAR sheet: ARRAY[1..maxR], [1..maxC] OF cell; 
automatic:BOOLEAN; 

PROCEDURE init; 

VAR row, coI:CARDINAL; 

BEGIN 

automatic :■ TRUE; 

FOR row :- 1 TO maxR DO 
FOR col :- 1 TO maxC DO 

sheetTrow, col].status Empty; 
sheet[row, colj.form :« emptyFormuI a; 
END; 

END; 

END init; 

PROCEDURE cI earAI I; 

VAR row, coI:CARDINAL; 

BEGIN 

FOR row :« 1 TO maxR DO 
FOR col :« 1 TO maxC DO 
WITH sheet[row, col] DO 
status :« Empty; 

Formula.free(form); 
form :* emptyFormuI a; 

END; 

END; 

END; 

END clearAII; 


PROCEDURE setAutomatic; 
BEGIN 

automatic :• TRUE; 
END setAutomatic; 

PROCEDURE setManual; 


(continued) 
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BEGIN 

automatic FALSE; 

END setManuaI; 

PROCEDURE InRange(row, coI:CARDINAL):BOOLEAN; 

BEGIN 

RETURN (row >■ 1) AND (row <- maxR) AND (col >- 1) AND (col <= maxC) 
END inRange; 7 

PROCEDURE setVaIue(row, coI:CARDINAL; vaIue:REAL); 

BEGIN ' 

IF InRange(row, col) THEN 

sheetTrow, coll.value ;■ value; 
sheet[row, col].status :* OK; 
operatlonStatus :* OK; 
dIspIayCeI I(row, col); 

IF automatic THEN 
recaIcuI ate; 

END; 

ELSE 

operatlonStatus :» RangeError; 

END; 

END setVaIue; 

PROCEDURE getVaIue(row, coI:CARDINAL):REAL; 

BEGIN 

IF NOT lnRange(row, col) THEN 

operatlonStatus :■ RangeError; 

RETURN 0.0; 

ELSIF sheet[row, col].status <> OK THEN 

operatlonStatus :■ sheetfrow, col].status: 

RETURN 0.0; 

ELSE 

operatlonStatus := OK; 

RETURN sheet[row, col].value; 

END; 

END getVaIue; 

PROCEDURE setFormuIa(row, coI:CARDINAL; f;formula); 

IF InRange(row, col) THEN 
WITH sheet[row, col] DO 
form f; 
value 0.0; 

status OK; 

evaIuateFormuIa(form, row, col, value, status); 
displayCelI(row, col); 

IF automatic THEN 
recalculate; 

END; 

END; 

operatlonStatus :■ OK; 

ELSE 

operatlonStatus :» RangeError; 

END; 

END setFormula; 

PROCEDURE getFormuIa(row, coI CARDINAL):formuI a; 

BEGIN 

IF InRange(row, col) THEN 
operatlonStatus :« OK; 

RETURN sheet[row, coll.form; 

ELSE 

operatlonStatus :« RangeError; 

RETURN emptyFormuI a; 

END; 

END getFormula; 

PROCEDURE cl ear(row, coI;CARDINAL); 

BEGIN J 

IF InRange(row, col) THEN 

sheetfrow, coll.status := Empty; 
sheet[row, colj.form :« emptyFormuI a; 
operatlonStatus :« OK; 

ELSE 
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operationStatus :* RangeError; 

END; 

END clear; 

PROCEDURE status(row, co I CARDINAL) -.Status; 

BEGIN 

IF inRange(row, col) THEN 
operationStatus :■ OK; 

RETURN sheet[row, col].status; 

ELSE 

operationStatus :* RangeError; 

RETURN RangeError; 

END; 

END status; 

PROCEDURE maxRow():CARDINAL; 

BEGIN 

RETURN maxR; 

END maxRow; 

PROCEDURE maxCoI():CARDINAL; 

BEGIN 

RETURN maxC; 

END maxCoI; 

PROCEDURE recalculate; 

VAR row, coI;CARDINAL; 
vaI:REAL; 
stat:Status; 

BEGIN 

FOR row :* 1 TO maxR DO 
FOR col :* 1 TO maxC DO 
WITH sheet[row, col] DO 

IF (status <> Empty) AND (status <> SyntaxError) 
AND (NOT Formula.empty(form)) THEN 
evaIuateFormuIa(form, row, col, val, stat); 

IF (stat <> status) OR (val <> value) THEN 
status :* stat; 
value :« val; 
displayCelI(row, col); 

END; 

END; 

END; 

END; 

END; 

operationStatus :■ OK; 

END recalculate; 


BEGIN 

END Spreadsheet. 


numstostr.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


pxEDEFINITION MODULE NumToString; 

EXPORT QUALIFIED cardToString, realToString; 

PROCEDURE cardToStrIng(c:CARDINAL; 

VAR s:ARRAY OF CHAR); 

PROCEDURE realToStrlng(r:REAL; precision: 
CARDINAL; VAR s:ARRAY OF CHAR); 

END NumToString. 
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mystor1.def 

Progrommlng Project: "Build o Spreadsheet Program,“ by 
Jonathan Amsterdam. July, page 96. 

DEFINITION MODULE MyStoragej 
FROM SYSTEM IMPORT ADDRESS; 

EXPORT QUALIFIED bytesPerWord, ALLOCATE, DEALLOCATE, available 
CONST bytesPerWord = 2; 

PROCEDURE ALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL); 

PROCEDURE DEALLOCATE(VAR a:ADDRESS; nBytesCARDINAL); 

PROCEDURE oval IabIe(nBytes: CARDINAL):BOOLEAN; 

END MyStorage. 


r.umtostr .mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE NumToString; 


frou ^ tr ‘ n 9 Stuf f IMP ?EL^ r ' n « L#n * f,ndCh <"-. InsertChar. deleteChar; 

FROM NumConversions IMPORT CardToStr; * 

FROM ReaIConversIons IMPORT RealToFormStr. RealProcResponses, 

RealConversionRes, Rea IToSciStr;* 

CONST maxDigits - 7; (* if the number would be larger than this, we use 

scientific notation and preserve this many digits *) 


™CEDURE cardToStr ing(c.-CARDINAL; VAR s:ARRAY OF CHAR); 

VAR fieldWIdthrCARDINAL; ' 

BEGIN 

(* keep trying to convert until success *) 
fieldWidth :« 0; ' 

REPEAT 

INC(fieldWidth); 

CardToStr(c, s, fieldWidth); 

UNTIL (s[0] <> 0C) (* success *) 

END cardTo?Jri.!gt ldWidth " ^ ( * '° n9eSt Cardina ' " 5 plaCes 


long *) 


BEGIN° URE realToStrin 9( r:REAL: precis Ion .-CARDINAL; VAR s : ARRAY OF CHAR); 

RealToFormStrtr. s, maxDigIts+2. precision); (* +2 for sign and dec. pt. *) 
IF Rea IConversionRes ■ fieldError THEN ” * ' 

(* string too long—use scientific notation *) 

END‘ RealT ° SCiStr ^ r ’ S * 101 2 ^ : 10 spaces ov *rall, 2 sig. digits *) 

cosmeticize(s); 

END reaIToString; 


PROCEDURE cosmeticize(VAR s:ARRAY OF CHAR); 
(* For reals only. Things to fix: 

1 • no Ieading bIanks 

2 . no leading zero: add one 

3. trailing zeros: delete them 

4. trailing decimal point: remove it 

*) 

VAR i:CARDINAL; 
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BEGIN 

(* delete leading blanks *) 

WHILE s[0] « * ' DO 
deleteChar(s, 0); 

END; 

(♦insert a leading 0 if necessary ♦) 
IF (s[0] « '.’) THEN 
insertChar(*0*, s, 0); 

END; 

(♦ remove trailing zeros ♦) 

I :* strlngLen(s)-1; 

WHILE s[i] - ’0’ DO 
s[i] :« 0C; 

DEC(i); 

END; 

(♦ remove trailing decimal point ♦) 
IF s[I] * THEN 
s[i] 0C; 

END; 

END cosmeticize; 

BEGIN 

END NumToString. 


screenha.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 

DEFINITION MODULE ScreenHandIer; 

EXPORT QUALIFIED init, setCursorPos, getCursorPos, Write, WriteString; 
PROCEDURE init; 

PROCEDURE setCur8orPos(row, coI:CARDINAL); 

PROCEDURE getCursorPos(VAR row, coI:CARDINAL); 

PROCEDURE Write(ch:CHAR); 

PROCEDURE WriteStrIng(s:ARRAY OF CHAR); 

END ScreenHandIer. 


mystor1.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE MyStorage; 

(♦ The "available" function should figure out how much memory is actually 
available, and return TRUE if that is >■ its argument. But for the 
purposes of testing, my function just assumes there are 5K available 
and decrements a counter each time it is called. You will want 
to change this if you intend to use the spreadsheet. ♦) 

IMPORT Storage; 

FROM SYSTEM IMPORT ADDRESS; 

PROCEDURE ALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL); 

BEGIN 

IF ava11abIe(nBytes) THEN 

Storage.ALLOCATE(a, (nBytes+1) DIV bytesPerWord); 

ELSE 

a :- NIL; 

END; 

END ALLOCATE; 


[continued] 
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PROCEDURE DEALLOCATE(VAR a:ADDRESS; nBytes:CARDINAL); 
BEGIN 

Storage.DEALLOCATE(a, (nBytes+1) DIV bytesPerWord); 
a :« NIL; 

END DEALLOCATE; 

VAR freeBytes:CARDINAL; 

PROCEDURE avaI IabIe(nBytes:CARDINAL):BOOLEAN; 

BEGIN 

IF nBytes <- freeBytes THEN 
DEC(freeBytes, nBytes); 

RETURN TRUE; 

ELSE 

RETURN FALSE; 

END; 

END avallable; 

BEGIN 

freeBytes :• 5 * 1024; (* 5K for testing purposes *) 

END MyStorage. 


mystir2.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE MyStorage2; 

FROM SYSTEM IMPORT ADDRESS; 

EXPORT QUALIFIED ALLOCATE, DEALLOCATE, available; 
PROCEDURE ALLOCATE (VAR a: ADDRESS; nWords .-CARDINAL) ; 
PROCEDURE DEALLOCATE(VAR a:ADDRESS; nWords:CARDINAL); 
PROCEDURE avaiIabIe(nWords:CARDINAL):BOOLEAN; 

END MyStorage2. 


mystor2.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE MyStorage2; 

(* The "available" function should figure out how much memory is actually 
available, and return TRUE if that is >= its argument. But for the 
purposes of testing, my function just assumes there are 6K available 
and decrements a counter each time it is called. You will want 
to change this if you intend to use the spreadsheet. *) 

IMPORT Storage; 

FROM SYSTEM IMPORT ADDRESS; 

VAR freeWordsCARDINAL; 

PROCEDURE ALLOCATE (VAR a .-ADDRESS; nWords : CARDINAL) ; 

BEGIN 

IF aval IabIe(nWords) THEN 

Storage.ALLOCATE(a, nWords); 

DEC(freeWords, nWords); 

ELSE 

a :« NIL; 

END; 

END ALLOCATE; 

PROCEDURE DEALLOCATE(VAR a:ADDRESS; nWords:CARDINAL); 
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BEGIN 

Storage.DEALLOCATE^, nWords); 

INC(freeWords, nWords); 
a NIL; 

END DEALLOCATE; 

PROCEDURE ava iI ab I e( nWo r ds :CARDINAL):BOOLEAN; 

BEGIN 

RETURN nWords <« freeWords; 

END avaitable; 

BEGIN 

freeWords :■ 3 * 1024; (* 3K words (6K bytes) for testing purposes *) 

END MyStorage2. 


disklo.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE DIsklO; 

(* For low-level I/O to a temporary disk file. Used in the virtual 
implementation of the spreadsheet. *) 


EXPORT QUALIFIED init, WriteReal, ReadReal, WriteString, ReadString, 

DiskAddress, WriteCard, ReadCard, startRead, startWrite, endRead, empty, 
endWrite, startRewrite, endRewrite, freeDiskStorage, nuIIDiskAddress, 
clear, freeDiskAddress; 

TYPE DiskAddress; 

VAR nulIDiskAddress:DiskAddress; 

PROCEDURE Init; 

PROCEDURE clear; 

PROCEDURE startWrite; 

PROCEDURE endWr11e():DIskAddress; 

PROCEDURE startRewrite(da:DiskAddress); 

PROCEDURE endRewrIte():DiskAddress; 

PROCEDURE startRead(da:DiskAddress); 

PROCEDURE endRead; 

PROCEDURE Wr1teReaI(r:REAL); 

PROCEDURE ReadReal(VAR r:REAL); 

PROCEDURE WrIteStr!ng(VAR s:ARRAY OF CHAR); 

PROCEDURE ReadStr1ng(VAR s:ARRAY OF CHAR); 

PROCEDURE Wr11eCard(c:CARDINAL); 

PROCEDURE ReadCard(VAR c:CARDINAL); 

PROCEDURE freeDiskStorage(VAR da:DiskAddress); 

(* Frees the disk address and the associated storage on the disk. *) 
PROCEDURE freeDiskAddress(VAR da:DiskAddress); 

PROCEDURE empty(da:DIskAddress):BOOLEAN; 

END DisklO. 
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formula.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 

DEFINITION MODULE Formula; 

EXPORT QUALIFIED formula, toStrlng, toFormula, free, write, empty, length, 
emptyFormula; 

TYPE formula; 

VAR emptyFormula:formuI a; 

PROCEDURE toStrIng(f:formula; VAR s:ARRAY OF CHAR); 

PROCEDURE toFormuI a(s:ARRAY OF CHAR):formuI a; 

PROCEDURE free(VAR f:formuI a); 

PROCEDURE wrIte(f:formuI a); 

PROCEDURE empty(f:formula):BOOLEAN; 

PROCEDURE Iength(f:formuI a):CARDINAL; 

END Formula. 


formuI a.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Formula; 


FROM StrlngStuff IMPORT strlngLen, strIngAssign; 
FROM MIsc IMPORT assert; 

FROM Terminal IMPORT Write; 

FROM MyStorage IMPORT allocate, deallocate; 

TYPE formula - POINTER TO ARRAY[0..32000] OF CHAR; 

PROCEDURE toStr!ng(f:formula; VAR s:ARRAY OF CHAR); 
VAR l, Ien:CARDINAL; 

BEGIN 

IF f - NIL THEN 
s[0] :« 0C; 

ELSE 

len :» length(f); 

FOR I :- 0 TO len-1 DO 
IF I > HIGH(s) THEN 
RETURN; 

ELSE 

s[I] f"[!]; 

END; 

END; 

IF len <« HIGH(s) THEN 
s[len] :■ 0C; 

END; 

END; 

END toStrlng; 

PROCEDURE toFormuIa(s:ARRAY OF CHAR):formuI a; 

VAR f:formuI a; 

I. Ien:CARDINAL; 

BEGIN 

len :» strIngLen(s); 

IF len = 0 THEN 
RETURN NIL; 
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ELSE 

f :* new(len); 

FOR i :■ 0 TO len-1 DO 
f-[I] : = s[1]; 

END; 

f*[Ien] 0C; 

RETURN f; 

END; 

END toFormula; 

PROCEDURE wrIte(f:formula); 

VAR I, Ien:CARDINAL; 

BEGIN 

len :*= length(f); 

IF len <> 0 THEN 

FOR i := 0 TO len-1 DO 
Wr1te(f A [I]); 

END; 

END; 

END write; 

PROCEDURE empty(f:formuI a):BOOLEAN; 

BEGIN 

RETURN f - NIL; 

END empty; 

PROCEDURE Iength(f:formula):CARDINAL; 

VAR i:CARDINAL; 

BEGIN 

IF f - NIL THEN 
RETURN 0; 

ELSE 

I :« 0; 

WHILE f*[I] <> 0C DO 
INC(i); 

END; 

RETURN I; 

END; 

END length; 

PROCEDURE new(nChars:CARDINAL):formula; 

VAR f:formula; 

BEGIN 

allocate(f, nChars+1); 

assert(f <> NIL, "FormuI a.new: out of room"); 
RETURN f; 

END new; 

PROCEDURE free(VAR f:formuI a); 

BEGIN 

IF f <> NIL THEN 

deallocate(f, length(f)+1); 
f :* NIL; 

END; 

END free; 

BEGIN 

emptyFormula :« NIL; 

END Formula. 


cel 1181.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE CellLlst; 

FROM Formula IMPORT formula; 

EXPORT QUALIFIED cellLlst, nextCell, InitFindDep, nextDep, cellRow, cellCol, 
addToCelI List, removeFromCeI I List, nuIICeI IList, empty, freeCelIList; 


[continued) 
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TYPE c«lILIet; 

VAR nul ICel IList :c«l ILIet; 

PROCEDURE empty(cl:celIList):BOOLEAN; 

PROCEDURE nextCelI(cl:celIList):celILIet; 

PROCEDURE celIRow(cl:celIL!et):CARDINAL; 

PROCEDURE cel I Co I(cl:celIL!st):CARDINAL; 

PROCEDURE initFIndDep(curRow, curCol:CARDINAL; f:formula); 
PROCEDURE nextDep(VAR row, col:CARDINAL):BOOLEAN; 

PROCEDURE addToCelILIet(VAR cl:celILIet; row. coI CARDINAL); 
PROCEDURE removeFromCeIILIet(VAR cltcelILIet; row, coI:CARDINAL); 
PROCEDURE freeCelILIet(VAR cl reelILIet); 

END CelILIet. 


commanddp.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE CommandProc; 

FROM InOut IMPORT ReadString; 

FROM Evaluator IMPORT evaIuateStrIng; 

IMPORT Formula; 

FROM Spreadsheet IMPORT Status; 

FROM StrlngStuff IMPORT strlngLen, flndChar, strlngCopy, string160, 
strlng80, strlngCap, deleteChar; 

FROM NumConversIons IMPORT StrToCard, NumConversionRes, NumProcResponses; 
FROM Terminal IMPORT Beep; 

FROM DispIayHandIer IMPORT wrltePrompt, dispIayFormuI a, message; 

FROM StringOps IMPORT Concat; 

VAR commandstring: string160; 
curRow, curCoI:CARDINAL; 

PROCEDURE readCommand(VAR c:command; crRow, crCo I-.CARDINAL); 

BEGIN 

curRow := crRow; 
curCoI :« crCoI; 
dispIayFormuIa(curRow, curCol); 

LOOP 

wr itePrompt(curRow, curCol); 

REPEAT 

ReadStrIng(commondString); 

UNTIL commandString[0] <> 0C; 
stringCap(commandString); 

IF commandParse(commandStrIng, c) THEN 
EXIT; 

END; 

END; 

END readCommand; 

PROCEDURE commandParse(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 

VAR ch:CHAR; 

BEGIN 

ch :■ s[0]; 

deIeteChar(s, 0); 

CASE ch OF 


170 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 









July 


’A’: 

c.type 

:® Automatic; 

* C *: 

RETURN 

copy(s, c); 

*D # : 

c.type 

:» Down; 

•F’: 

RETURN 

setFormula(s, c); 

*K 

c.type 

:* Clear; 

*L # : 

c.type 

Left; 

'M*: 

c.type 

Manua1; 

# N*: 

RETURN 

o 

CO 

L_ 

a> 

c 

i_ 

o 

a> 

c 

•P*: 

RETURN 

preclsion(s, c); 

* Q *: 

c.type 

:* Quit; 

*R*: 

c.type 

Right; 

'U*: 

c.type 

:■ Up; 

•V: 

RETURN 

setValue(s, c); 


RETURN 

co1Wldth(s, c); 


c.type 

:* Recalc; 
doCe1IRef(s, c); 


RETURN 

ELSE 

Beep; 

s[0] 

:* 0C; 


message("II IegaI character"); 
RETURN FALSE; 


END; 

RETURN TRUE; 

END commandParse; 

PROCEDURE copy(VAR s:ARRAY OF CHAR; VAR c;command):BOOLEAN; 

BEGIN 

c.type :« Copy; 

RETURN celIRef(s, c); 

END copy; 

PROCEDURE setFormuIa(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 
BEGIN 

c.type :■ SetFormula; 

c.form :* FormuI a.toFormuIa(s); 

RETURN TRUE; 

END setFormula; 

PROCEDURE newCorner(VAR s:ARRAY OF CHAR; VAR c:command);BOOLEAN; 
BEGIN 

c.type :■ NewCorner; 

RETURN celIRef(s. c); 

END newCorner; 

PROCEDURE prec!slon(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 
BEGIN 

c.type :■ Precision; 

RETURN cardFromStrlng(s, c.precIsI on); 

END precision; 

PROCEDURE setVaIue(VAR s:ARRAY OF CHAR; VAR c:command)iBOOLEAN; 
VAR stat:Status; 

BEGIN 

evaluateStrlng(s, curRow, curCol, c.value, stat); 
c.type SetValue; 

IF stat <> OK THEN 
cantEvalMsg(s); 

END; 

RETURN stat - OK; 

END setValue; 


PROCEDURE coIWldth(VAR s;ARRAY OF CHAR; VAR c:command):BOOLEAN; 
BEGIN 

c.type :« ColWidth; 

RETURN cardFromStrlng(s, c.colWIdth); 

END colWldth; 

PROCEDURE doCeI I Ref(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 
VAR b:BOOLEAN; 

BEGIN 

b ;■ cel I Re f1(s, c); 
c.type Cell Ref; 

RETURN b; 

END doCelI Ref; 


(continued) 
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PROCEDURE ceI I Ref(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 

(* Syntax: [ <formulo> , <formula> ] *) 

VAR IeftPos:CARDINAL; 

BEGIN 

IF NOT fIndChar(•, *[\ leftPos) THEN 
message("II legal cell specification—no left bracket 1 '); 

RETURN FALSE; 

ELSE 

WHILE s[0] <> ’[• DO 
deIeteChar(s, 0); 

END; 

deIeteChar(e, 0); 

RETURN celIRef1(s, c); 

END; 

END cel I Ref; 

PROCEDURE cel I Ref 1(VAR s:ARRAY OF CHAR; VAR c:command):BOOLEAN; 

(* Syntax: <formula> , <formula> ] *) 

VAR st:Status; 
v:REAL; 

rowForm, colForm: strlng80; 
commaPos, rIghtPos:CARDINAL; 

BEGIN 

IF (NOT flndChar(s, commaPos)) OR 

(commaPos ■ 0) OR 
(commaPos ■ strlngLen(s)-1) THEN 
message("IIlegal cell specification—bad comma"); 

RETURN FALSE; 

ELSIF (NOT f!ndChar(s, ']’, rightPos)) OR (rlghtPos < commaPos) THEN 
message("II IegaI ceil specification—bad right bracket"); 

RETURN FALSE; 

ELSE 

strIngCopyfrowForm, s, 0, commaPos-1); 

str IngCopy(colForm, s, commaPos+1, rightPos-1); 

evaIuateStrIng(rowForm, curRow, curCol, v, st); 

IF st <> OK THEN 

cantEvaIMsg(rowForm); 

RETURN FALSE; 

ELSE 

c.row :- TRUNCfv); 

evaluateString(colForm, curRow, curCol, v, st); 

IF st <> OK THEN 

cantEvaIMsg(coI Form); 

RETURN FALSE; 

ELSE 

c.col :- TRUNC(v); 

RETURN TRUE; 

END; 

END; 

END; 

END cel I Ref 1; 

PROCEDURE cardFromStrIng($:ARRAY OF CHAR; VAR c:CARDINAL):BOOLEAN; 
BEGIN 

StrToCard(s, c); 

IF NumConverslonRes <> noError THEN 

message("CouId not convert number"); 

END; 

RETURN NumConverslonRes = noError; 

END cardFromStrIng; 

PROCEDURE cantEvaIMsg(formStrIng:ARRAY OF CHAR); 

VAR msg:strlng160; 

BEGIN 

Concat(msg, "Cannot evaluate ", formStrlng); 
message(msg); 

END cantEvalMsg; 

BEGIN 

END CommandProc. 

ELSE 

operatlonStatus :■ RangeError; 

END; 

END clear; 
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PROCEDURE status(row, coI:CARDINAL):Status; 
BEGIN 

IF InRange(row, col) THEN 
operatlonStatus :* OK; 

RETURN sheet[row, col].status; 

ELSE 

operatlonStatus :* RangeError; 

END; 

END status; 


PROCEDURE maxRowQ: CARD INAL; 

BEGIN 

RETURN maxR; 

END maxRow; 

PROCEDURE maxCoI () .-CARDINAL; 

BEGIN 

RETURN maxC; 

END maxCoI; 

PROCEDURE recalculate; 

VAR row, col CARDINAL; 
val:REAL; 
statiStatus; 

BEGIN 

FOR row 1 TO maxR DO 
FOR col ;* 1 TO maxC DO 
WITH sheet[row, col] DO 

IF (status » OK) AND (NOT FormuIa.empty(form)) THEN 
evaluateFormula(form, row, col, val, stat); 

IF (stat <> status) OR (val <> value) THEN 
status :■ stat; 
value val; 

dlsplayCelI(row, col); 

END; 

END; 

END; 

END; 

END; 

operatlonStatus OK; 

END recalculate; 


BEGIN 

END Spreadsheet. 


ceI 12.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Cell; 

(* This module Implements the virtual spreadsheet. It uses the module 
DisklO for low-level I/O. Despite what It says in the article, I 
do not check touchCount for overflow. *) 

FROM Cel ILIst IMPORT ceI ILIst, nuIICeIILIst. freeCeI IList, nextCell, 
ceI I Row, cellCol, addToCeI ILIst; 

IMPORT CelILIst; 

FROM MyStorage2 IMPORT ALLOCATE. DEALLOCATE; 

FROM Formula IMPORT formula, emptyFormuI a; 

IMPORT Formula; 

FROM Misc IMPORT fatal, assert; 

FROM Spreadsheet IMPORT Status; 

FROM DisklO IMPORT DIskAddress, Init, WrtteReal, ReadReal, WriteString, clear, 
ReadString, WriteCard, ReadCard, freeDiskStorage, nuI IDiskAddress, empty, 
startWrite, endWrlte, startRewrIte, endRewrite, startRead, endRead, 
freeDIskAddress; 

FROM StrlngStuff IMPORT string255; 


(continued) 
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CONST nRows ■ 10; 
nCole ■ 10; 


TYPE 

cellArray - ARRAY[0..nRows-1], [0..nCoIe-1] OF cell; 
cellArrayPtr ■ POINTER TO cellArray; 
ceIIChunkPtr - POINTER TO cellChunk; 
celIChunk - RECORD 

startRow, startCol:CARDINAL; 
down, right; ceIIChunkPtr; 

InMemory, dlrty:BOOLEAN; 
touchedLastrCARDINAL; 
dlskAddr:DIskAddress; 
ceI I 8: cel IArrayPtr; 

END; 

VAR sheet:ceIIChunkPtr; 
touchCount:CARDINAL; 

PROCEDURE InItSheet; 

BEGIN 

sheet :« newCeIIChunk(1, 1, NIL, NIL); 
inlt; (* DisklO *) 
touchCount :■ 0; 

END InltSheet; 

PROCEDURE clearSheet; 

VAR rowCcp, coICcp, temp;ceIIChunkPtr; 

BEGIN 

clear; (* DisklO *) 
rowCcp :■ sheet; 

WHILE rowCcp <> NIL DO 
coICcp :■ rowCcp".rIght; 

WHILE coICcp <> NIL DO 
temp :■ coICcp; 
coICcp :■ coICcp".right; 
freeCelIChunk(temp); 

END; 

temp :■* rowCcp; 
rowCcp :« rowCcp".down; 
freeCelIChunk(temp); 

END; 

InltSheet; 

END clearSheet; 

PROCEDURE getCeI I(row, coI:CARDINAL; VAR creel I); 

VAR ccprceIIChunkPtr; 

BEGIN 

INC(touchCount); 

IF findCelIChunk(row, col, ccp) THEN 
IF NOT ccp".InMemory THEN 
getCelIsFromDisk(ccp); 

END; 

WITH ccp" DO 

c r* cells"[row-startRow, co1-startCoI]; 
touchedLast ;■ touchCount; 

END; 

ELSE 

cIearCeI I(c); 

END; 

END getCelI; 

PROCEDURE setCeI I(row, coI:CARDINAL; creel I); 

VAR ccprceIIChunkPtr; 

BEGIN 

INC(touchCount); 

IF NOT fIndCeIIChunk(row, col, ccp) THEN 
ccp r» addCeIIChunk(row, col, ccp); 

END; 

IF NOT ccp".InMemory THEN 
getCelIsFromDIsk(ccp); 

END; 

WITH ccp" DO 

ceI Is"[row-startRow, co1-startCoI] r= c; 
touchedLast r= touchCount; 
dirty r= TRUE; 
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END; 

END setCeI I; 


PROCEDURE addCeIIChunk(row, coI:CARDINAL; ccp:ceIIChunkPtr):ceIIChunkPtr; 

VAR newCcp:ceIIChunkPtr; 

BEGIN 

newCcp :* newCeIIChunk(start(row, nRows), start(col, nCols), NIL, NIL); 
WITH ccp* DO 

IF (row >* startRow) AND (row < startRow+nRows) THEN 

(* the new cell chunk belongs to the right of this one *) 
newCcp*.rIght right; 
right newCcp; 

ELSIF row >■ startRow+nRows THEN 

(* the new cell chunk belongs below this one *) 

IF (down ■ NIL) OR (row < down*.startRow) THEN 
(* the new cell chunk belongs directly below *) 
newCcp*.down :* down; 
down :« newCcp; 

ELSE (* It belongs to the left of the one below ★) 

assert((row >» down*.startRow) AND (row < down*.startRow+nRows), 
"addCeIIChunk: wrong chunk returned"); 
newCcp*.rIght :« down; 
newCcp*.down :* down*.down; 
down :* newCcp; 

END; 

ELSE 

fata I('addCeIIChunk: wrong cell chunk returned*); 

END; 

END; 

RETURN newCcp; 

END addCeIIChunk; 

PROCEDURE start(rowOrCoI, n:CARDINAL):CARDINAL; 

(* computes start row or start col. *) 

BEGIN 

RETURN ((rowOrCo1-1) DIV n)*n + 1; 

END start; 

PROCEDURE findCeIIChunk(row, coI:CARDINAL; VAR ccp:ceIIChunkPtr):BOOLEAN; 

(* Returns TRUE If It finds the cell chunk containing the cell [row,col]. 

If It returns FALSE, then ccp will point to the cell chunk just "before- 
where the right cell chunk should be. Before can mean just above, 
or Just to the left, depending upon where the new cell chunk should be 
put. *) 

BEGIN 

ccp :» sheet; 

WHILE row >* ccp*.startRow+nRows DO 
WITH ccp* DO 

IF (down ■ NIL) (* need to add a new chunk below this one *0 

OR frow < down*.startRow) (* need new chunk between this and next *) 
OR (frow < down*.startRow+nRows) AND 

(col < down*.startCol)) THEN (* need new chunk below & left *) 
RETURN FALSE; 

ELSE 

ccp :* down; 

END; 

END; 

END; 

(* We are now on the correct row *) 

WHILE col >■ ccp*.8tartCol+nCols DO 

IF (ccp*.right - NIL) OR (col < ccp*.rIght*.startCoI) THEN 
RETURN FALSE; 

ELSE 

ccp :■ ccp*.right; 

END; 

END; 

RETURN TRUE; 

END fIndCelIChunk; 

PROCEDURE doForAIICells(cp:celIProc); 

VAR rowCcp, coICcp;ceIIChunkPtr; 

BEGIN 

rowCcp sheet; 

REPEAT 
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coICcp:- rowCcp; 

REPEAT 

doForCelIChunk(coICcp, cp); 
coICcp :■ coICcp*.rIght; 

UNTIL coICcp - NIL; 
rowCcp :■ rowCcp*.down; 

UNTIL rowCcp - NIL; 

END doForAIICeI Is; 

PROCEDURE doForCelIChunk(ccp:ceIIChunkPtr; cp:celIProc); 
VAR row, coI:CARDINAL; 

BEGIN 

WITH ccp* DO 

IF NOT InMemory THEN 

getCelIsFromDisk(ccp); 

END; 

FOR row :■ startRow TO startRow+nRows-1 DO 
FOR col :« startCol TO startCoI+nCoIs-1 DO 

cp(row, col, ceI Is*[row-startRow, co1-startCoI]); 
END; 

END; 

END; 

END doForCelIChunk; 


PROCEDURE newCelIChunk(startR, startC:CARDINAL; d,r:celIChunkPtr):ceIIChunkPtr 

VAR ccpicelIChunkPtr; 

BEGIN 

NEW(ccp); 

WHILE ccp ■ NIL DO (* out of memory; throw out a chunk to disk *) 
putCelIsOnDisk; 

NEW(ccp); 

END; 

WITH ccp* DO 

cells :■ newCelIArray(); 

startRow startR; 

startCol startC; 

down :* d; 

right r; 

inMemory :* TRUE; 

dirty TRUE; 

touchedLast 0; 

dlskAddr :■ nuIIDiskAddress; 

END; 

RETURN ccp; 

END newCeIIChunk; 

PROCEDURE freeCeIIChunk(VAR ccp:ceIIChunkPtr); 

BEGIN 

IF ccp^.inMemory THEN 

freeCelIArray(ccp A .ceI Is); 

END; 

freeDiskAddress(ccp A .diskAddr); 

DISPOSE(ccp); 

ccp :«* NIL; 

END freeCelIChunk; 

PROCEDURE newCelIArray():cellArrayPtr; 

VAR captceI IArrayPtr; 

BEGIN 

NEW(cap); 

WHILE cap = NIL DO 
putCeI IsOnDisk; 

NEW(cap); 

END; 

clearCellArray(cap); 

RETURN cap; 

END newCeI IArray; 

PROCEDURE freeCeI IArray(VAR cap;ceI IArrayPtr); 

VAR row, coI:CARDINAL; 

BEGIN 

FOR row :« 0 TO nRows-1 DO 
FOR col :« 0 TO nCols-1 DO 
WITH cap*[row, col] DO 
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freeCelIList(dependentCeI Is); 

FormuI a.free(form); 

END; 

END; 

END; 

DISPOSE(cap); 
cap :« NIL; 

END freeCeI IArray; 

PROCEDURE clearCelIArray(VAR copies I IArrayPtr); 

VAR row, col:CARDINAL; 

BEGIN 

FOR row :« 0 TO nRows-1 DO 
FOR col i- 0 TO nCols-1 DO 
clearCelI(cap"[row, col]); 

END; 

END; 

END cIearCeI I Array; 

PROCEDURE clearCelI(VAR cice II); 

BEGIN 

WITH c DO 

status :* Empty; 
form i« emptyFormuI a; 
dependentCeI Is i- nuIICeI ILIst; 

END; 

END clearCelI ; 

(* Virtual memory stuff *) 

PROCEDURE getCelIsFromDIsk(ccpiceIIChunkPtr); 

BEGIN 

WITH ccp" DO 

cells i- newCeI IArray(); (* This may result in a chunk being swapped out *) 
readCeI Is(ceI Is, diskAddr); 
inMemory i« TRUE; 
dirty i- FALSE; 

END; 

END getCeI IsFromDIsk; 

PROCEDURE putCelIsOnDisk; 

VAR ccpiceIIChunkPtr; 

BEGIN 

ccp i- fIndChunkToThrowOut(); 

WITH ccp" DO 
IF dirty THEN 

writeCells(ccp".celIs, ccp".diskAddr); 

END; 

freeCelIArray(celIs); 
inMemory ;* FALSE; 

END; 

END putCelIsOnDisk; 


PROCEDURE flndChunkToThrowOut()icelIChunkPtr; 

(* Uses LRU to find chunk to discard. Looks through every cell chunk in 
memory, returning the one accessed least recently. 

Resets touchCount. *) 

VAR rowCcp, ccp, IruCcpicelIChunkPtr; 

BEGIN 

IruCcp :■ NIL; (* the least recently used chunk found *) 

rowCcp i* sheet; 

WHILE rowCcp <> NIL DO 
ccp :* rowCcp; 

WHILE ccp <> NIL DO 
WITH ccp" DO 
IF inMemory AND 

((IruCcp ■ NIL) OR (touchedLast < IruCcp".touchedLast)) THEN 
IruCcp :« ccp; 

END; 

ccp ;■ right; 

END; 

END; 

rowCcp rowCcp".down; 

END; 
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assort(IruCcp <> NIL, "fIndChunkToThrowOut: no chunks In memory!"); 

(* This is possible if, say, there are so many cell chunks allocated 
that the storage for them, even when the cells parts are on disk, 
exceeds memory capacity. *) 

RETURN IruCcp; 

END fIndChunkToThrowOut; 

PROCEDURE wrIteCells(cap:cellArrayPtr; VAR da:DiskAddress); 

VAR s:string255; 

row, coI:CARDINAL; 

BEGIN 

IF empty(da) THEN 
startWrite; 

ELSE 

startRewrIte(da); 

END; 

FOR row :■ 0 TO nRows-1 DO 
FOR col 0 TO nCols-1 DO 
WITH cap~[row,col1 DO 
WrIteReal(value;; 

WrIteCard(CARDINAL(status)); 

FormuI a.toStrIng(form, s); 

WriteString(s); 

writeCelIList(dependentCeI Is); 

END; 

END; 

END; 

IF empty(da) THEN 
da :« endWriteQ; 

ELSE 

da :■ endRewrIte(); 

END; 

END wr i teCe Ms; 

PROCEDURE readCeI Is(cap:ceI IArrayPtr; da:DIskAddress); 

VAR s:strlng255; 

row, col, temp:CARDINAL; 

BEGIN 

startRead(da); 

FOR row :* 0 TO nRows-1 DO 
FOR col 0 TO nCols-1 DO 
WITH cap~[row,col] DO 
ReadReaI(vaIue); 

ReadCard(temp); 
status :■ Status(temp); 

ReadStrlng(s); 

form :* FormuI a.toFormuIa(s); 
readCelIList(dependentCeI Is); 

END; 

END; 

END; 

endRead; 

END readCelIs; 

PROCEDURE writeCelILIst(cI:ceI IList); 

(* Writes a cell list by first writing Its length, then the pairs of row,col *) 
VAR clisticelIList; 

Ien:CARDINAL; 

BEGIN 

clist :« cl; 
len :■ 0; 

WHILE NOT CelIList.empty(clist) DO 
INC(len); 

clist :* nextCeI I(cIist); 

END; 

WriteCard(len); 
clist :* cl; 

WHILE NOT CelIList.empty(clist) DO 
WrlteCard(cellRow(cl1st)); 

WriteCard(celI Co I(clist)); 
clist :* nextCeI 1(cIist); 

END; 

END writeCelIList; 

PROCEDURE readCelI List(VAR c1:ceI 1List); 

VAR len, i, row, coI:CARDINAL; 

BEGIN 
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ReadCard(Ien); 
cl :■ nulICelIList; 

IF len <> 0 THEN 
FOR I :« 1 TO len DO 
ReadCardfrow}; 

ReadCard(coI); 

addToCelIList(cI, row, col); 

END; 

END; 

END readCelI List; 

(* * For debugging only. 

PROCEDURE wrIteChunk(ccp:ceIIChunkPtr); 
BEGIN 

WriteOP); 

MyTerminal.WriteCard(ccp^.startRow, 0); 
Wr I te(•,•); 

MyTerminal.WriteCard(ccp^.startCoI, 0); 
Wr 1 te(']*); 

END writeChunk; 

*) 

BEGIN 
END Cell. 


commandp.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE CommandProc; 

FROM Formula IMPORT formula; 

EXPORT QUALIFIED command, CommandType, readCommand; 

TYPE CommandType - (CellRef, SetValue, SetFormula, Left, Right, Up, Down, 
NewCorner, Precision, ColWidth, Automatic, Manual, 
Recalc, Copy, Clear, Quit); 

command ■ 

RECORD 

CASE type:CommandType OF 

CellRef, NewCorner, Copy: row, coI:CARDINAL; 

SetValue: value:REAL; 

SetFormula: form: formula; 

Precision: prec1sion:CARDINAL; 

ColWidth: coIWldthCARDINAL; 

END; 

END; 

PROCEDURE readCommand(VAR cicommand; crRow, crCoI:CARDINAL); 

END CommandProc. 


ceI 11st.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE CelIList; 

(* Implements cell lists, and finding dependencies in formulas. 

*) 

FROM StrlngStuff IMPORT string160, flndChar; 

FROM Formula IMPORT formula; 

IMPORT Formula; 

FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM MyTerminal IMPORT WrlteString, WriteCard, WriteLnStrIng; 

FROM Evaluator IMPORT refexpr; 

[continued) 
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FROM Spreadsheet IMPORT Status; 

FROM StrlngOps IMPORT Delete; 

TYPE 

cel(List - POINTER TO cel INode; 
cel INode - RECORD 

row, coI:CARDINAL; 
next:celILIst; 

END; 

VAR strIngrstrIng160; 
cRow, cCoI:CARDINAL; 

PROCEDURE empty(cI:ceI IL1st);BOOLEAN; 

BEGIN 

RETURN cl - NIL; 

END empty; 

PROCEDURE nextCelI(cl:celILIst);ceIILIst; 

BEGIN 

RETURN cr.next; 

END nextCelI; 

PROCEDURE celIRow(cl:celILIst):CARDINAL; 

BEGIN 

RETURN cl A .row; 

END ceI I Row; 

PROCEDURE cel I Co I(cl;cel ILIst):CARDINAL; 

BEGIN 

RETURN cl*.col; 

END celICoI; 

PROCEDURE In11FIndDep(curRow, curCo I;CARDINAL; f:formula); 
BEGIN 

FormuI a.toStrIng(f, string); 
cRow :* curRow; 
cCoI ;* curCoI; 

END InItFIndDep; 

PROCEDURE nextDep(VAR row, co I : CARD I NAL) -.BOOLEAN; 

(* assumes syntactically correct formula *) 

VAR IbPos, commaPos, rbPos:CARDINAL; 
vCol, vRowiREAL; 
srStatus; 

BEGIN 

IF (NOT flndChar(string, ’[*. IbPos)) OR 
(NOT fIndChar(strIng, commaPos)) OR 

(NOT findChar(string, ']', rbPos)) THEN 
RETURN FALSE; 

ELSE 

INC(IbPos); 

refexpr(strIng, IbPos, vRow, s, cRow); 

IF s <> OK THEN 

WrIteLnStrIngC'nextDep; s <> OK"); 

END; 

INC(commaPos); 

refexpr(strIng, commaPos, vCol, s, cCol); 

IF s <> OK THEN 

WrIteLnString("nextDep: s <> OK"); 

END; 

row TRUNC(vRow); 

col TRUNC(vCol); 

Delete(string, 0, rbPos+1); 

RETURN TRUE; 

END; 

END nextDep; 

PROCEDURE addToCelI List(VAR cl:ceIILIst; row, coI:CARDINAL); 
VAR newcI:ceI IL1st; 

BEGIN 

IF NOT member(row, col, cl) THEN 
NEW(newcl); 
newcl^.row :• row; 
newc I *\co I :« co I ; 
newcl^.next :» cl; 
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cl newcI; 

END; 

END addToCeIILIst; 

PROCEDURE member(row, coI:CARDINAL; cl:celIList):BOOLEAN; 

BEGIN 

WHILE cl <> NIL DO 

IF (row * cl*.row) AND (col » cl*.col) THEN 
RETURN TRUE; 

ELSE 

cl :* cl*.next; 

END; 

END; 

RETURN FALSE; 

END member; 

PROCEDURE removeFromCeIIList(VAR cl:celILIst; row, coI:CARDINAL); 
(* Writes error If not found. *) 

VAR temp, prev:ceI ILIst; 

BEGIN 

temp :* cl; 
prev :* NIL; 

WHILE temp <> NIL DO 

IF (temp^.row « row) AND (temp*.col « col) THEN 
IF temp - cl THEN 
cl :■ cl*.next; 

ELSE 

prev*.next :■ temp^.next; 

END; 

DISPOSE(temp); 

RETURN; 

ELSE 

prev :* temp; 
temp temp*.next; 

END; 

END; 

Wr IteStr Ing("removeFromCel ILIst: "); 

WrIteCardfrow, 3); 

WrlteCard(coI, 3); 

Wr I teLnStrIng(" not found"); 

END removeFromCeIILIst; 

PROCEDURE freeCeI ILIst(VAR cl:ceIILIst); 

VAR temp:celILIst; 

BEGIN 

WHILE cl <> NIL DO 
temp :* cI; 
cl :■ cI*.next; 

DISPOSE(temp); 

END; 

END freeCelILIst; 

BEGIN 

nulICelILIst :■ NIL; 

END CelILIst. 


cell.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE Cell; 

FROM CelILIst IMPORT celILIst; 

FROM Formula IMPORT formula; 

FROM Spreadsheet IMPORT Status; 

EXPORT QUALIFIED cell, getCell, setCell, doForAIICelIs, 
InltSheet, clearSheet, cellProc; 


TYPE 

cel I - RECORD 
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value: REAL; 
form: formula; 
status: Status; 
dependentCelIs: celILIst; 

END; 

cellProc - PROCEDURE(CARDINAL, CARDINAL, VAR cell); 


PROCEDURE InitSheet; 

PROCEDURE clearSheet; 

PROCEDURE getCeI I(row, coI:CARDINAL; VAR c:cell); 
PROCEDURE setCeI I(row, coI:CARDINAL; c:cell); 
PROCEDURE doForAIICells(cp:celIProc); 

END Cell. 


ceI 11.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Cell; 

FROM CelILIst IMPORT ceI ILIst, nuIICeI ILIst, freeCeIILIst; 
FROM Storage IMPORT ALLOCATE, DEALLOCATE; 

FROM Formula IMPORT formula, emptyFormuI a; 

IMPORT Formula; 

FROM Mlsc IMPORT fatal, assert; 

FROM Spreadsheet IMPORT Status; 

CONST nRows - 10; 
nCols ■ 10; 


TYPE 

cellArray - ARRAY[0..nRows-1],[0..nCoIs-1] OF cell; 
ceIIChunkPtr - POINTER TO cellChunk; 
cel IChunk - RECORD 

startRow, startCol:CARDINAL; 

cells:cellArray; 

down, right: ceIIChunkPtr; 

END; 

VAR sheet:celIChunkPtr; 

PROCEDURE InitSheet; 

BEGIN 

sheet :« newCeIIChunk(1, 1, NIL, NIL); 

END InitSheet; 

PROCEDURE clearSheet; 

VAR rowCcp, coICcp, temp:ceIIChunkPtr; 

BEGIN 

rowCcp :« sheet; 

WHILE rowCcp <> NIL DO 
coICcp :* rowCcp^.right; 

WHILE coICcp <> NIL DO 
temp :« coICcp; 
coICcp :■ coICcp^.right; 
freeCelIChunk(temp); 

END; 

temp :« rowCcp; 
rowCcp :* rowCcp^.down; 
freeCelIChunk(temp); 

END; 

initSheet; 

END clearSheet; 

PROCEDURE getCeI I(row, coI:CARDINAL; VAR c:cell); 

VAR ccp:ceIIChunkPtr; 
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BEGIN 

IF findCelIChunk(row, col, ccp) THEN 
WITH ccp" DO 

c cel 18[row-8tartRow, co1-startCoI]; 

END; 

ELSE 

cIearCeI I(c); 

END; 

END getCelI; 

PROCEDURE setCeI I(row, coIiCARDINAL; creel I); 

VAR ccprcelIChunkPtr; 

BEGIN 

IF NOT fIndCeIIChunk(row, col, ccp) THEN 
ccp :■ addCeIIChunk(row, col, ccp); 

END; 

WITH ccp" DO 

ceI Is[row-startRow, co1-startCoI] :* c; 

END; 

END setCeI I; 

PROCEDURE addCelIChunk(row, col:CARDINAL; ccprcelIChunkPtr)rceIIChunkPtr; 

VAR newCcprcelIChunkPtr; 

BEGIN 

newCcp :« newCelIChunk(start(row, nRows), start(col, nCols), NIL, NIL); 
WITH ccp" DO 

IF (row >- startRow) AND (row < startRow+nRows) THEN 

(* the new cell chunk belongs to the right of this one *) 
newCcp".right :• right; 
right r* newCcp; 

ELSIF row >■ startRow+nRows THEN 

(* the new cell chunk belongs below this one *) 

IF col < down".startCol THEN 

(* the new cell chunk belongs to the left of the one below *) 
assert((row >■ down".startRow) AND (row < down".startRow+nRows), 
"addCelIChunk: wrong chunk returned"); 
newCcp".right r* down; 
newCcp".down :■ down".down; 
down r* newCcp; 

ELSE (* it just belongs directly below *) 
newCcp".down down; 
down :• newCcp; 

END; 

ELSE 

fatal('addCelIChunkr wrong cell chunk returned'); 

END; 

END; 

RETURN newCcp; 

END addCelIChunk; 

PROCEDURE star t (rowOrCo I , n -.CARDINAL) r CARD INAL; 

(* computes start row or start col. *) 

BEGIN 

RETURN ((rowOrCo1-1) DIV n)*n + 1; 

END start; 

PROCEDURE findCelIChunk(row, coIiCARDINAL; VAR ccp:ceIIChunkPtr);BOOLEAN; 

(* Returns TRUE if It finds the cell chunk containing the cell [row,col]. 

If it returns FALSE, then ccp will point to the cell chunk just "before" 
where the right cell chunk should be. Before can mean just above, 
or just to the left, depending upon where the new cell chunk should be 
put. *) 

BEGIN 

ccp :■ sheet; 

WHILE row >- ccp".startRow+nRows DO 
WITH ccp" DO 

IF (down ■ NIL) (* need to add a new chunk below this one *) 

OR (row < down".startRow) (* need new chunk between this and next *; 
OR ((row < down".startRow+nRows) AND 

(col < down".startCol)) THEN (* need new chunk below k left *) 
RETURN FALSE; 

ELSE 

ccp down; 

END; 

END; 
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END; 

(* We are now on the right row *) 

WHILE col >- ccp*.startCol+nCols DO 

IF (ccp*.right - NIL) OR (col < ccp*.right*.startCoI) THEN 
RETURN FALSE; 

ELSE 

cep ;■ ccp*.right; 

END; 

END; 

RETURN TRUE; 

END findCelI Chunk; 

PROCEDURE doForAIICells(cp:celIProc); 

VAR rowCcp, coICcprcelIChunkPtr; 

BEGIN 

rowCcp :■ sheet; 

REPEAT 

coICcp:- rowCcp; 

REPEAT 

doForCeIIChunk(coICcp, cp); 
coICcp :« coICcp*.right; 

UNTIL coICcp - NIL; 
rowCcp :« rowCcp*.down; 

UNTIL rowCcp - NIL; 

END doForAIICelIs; 

PROCEDURE doForCelIChunk(ccp:ceIIChunkPtr; cpicelIProc); 

VAR row, coI:CARDINAL; 

BEGIN 

WITH cep* DO 

FOR row :« startRow TO startRow+nRows-1 DO 
FOR col :■ startCol TO startCol+nCols-1 DO 

cp(row, col, eel Isfrow-startRow, co1-startCoI]); 

END; 

END; 

END; 

END doForCelIChunk; 


PROCEDURE newCelIChunk(startR, startCrCARDINAL; d,r;ceIIChunkPtr):ceIIChunkPtr 
VAR ccprcelIChunkPtr; 

BEGIN 

NEW(ccp); 

WITH cep* DO 

startRow startR; 
startCol :» startC; 
down :« d; 
right :« r; 
clearCelIChunk(ccp); 

END; 

RETURN cep; 

END newCeIIChunk; 

PROCEDURE freeCeIIChunk(VAR ccp:celIChunkPtr); 

VAR row, col:CARDINAL; 

BEGIN 

FOR row 0 TO nRows-1 DO 
FOR col :« 0 TO nCols-1 DO 
WITH cep*.eells[row, col] DO 
freeCelIList(dependentCeI Is); 

Formula.free(form); 

END; 

END; 

END; 

DISPOSE(ccp); 
ccp :« NIL; 

END freeCelIChunk; 

PROCEDURE cIearCeIIChunk(VAR ccp:ceIIChunkPtr); 

VAR row, coI:CARDINAL; 

BEGIN 

FOR row :■ 0 TO nRows-1 DO 
FOR col :» 0 TO nCols-1 DO 

clearCelI(ccp*.cells[row, col]); 

END; 
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END; 

END cIearCeIIChunk; 

PROCEDURE clearCeI I(VAR c:cell); 
BEGIN 

WITH c DO 

status :■ Empty; 
form :* emptyFormuI a; 
dependentCeIIs :■ nuI ICeI ILIst; 
END; 

END cIearCeI I; 

BEGIN 
END Cell. 


misc.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE Mi sc; 

FROM MyTermlnal IMPORT pause, WriteLnString; 

PROCEDURE fatal(msg:ARRAY OF CHAR); 

BEGIN 

Wr iteLnString(msg); 
pause('Hit any key to die—’); 

HALT; 

END fatal; 

PROCEDURE assert(testrBOOLEAN; msg:ARRAY OF CHAR); 
BEGIN 

IF NOT test THEN 
fatal(msg); 

END; 

END assert; 

PROCEDURE max(a, b:CARDINAL):CARDINAL; 

BEGIN 

IF a > b THEN 
RETURN a; 

ELSE 

RETURN b; 

END; 

END max; 

PROCEDURE min(a, b:CARDINAL):CARDINAL; 

BEGIN 

IF a < b THEN 
RETURN a; 

ELSE 

RETURN b; 

END; 

END min; 

BEGIN 
END Misc. 


mi sc.def 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


DEFINITION MODULE Misc; 

EXPORT QUALIFIED fatal, assert, max, min; 


(continued) 
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PROCEDURE fatal(msg:ARRAY OF CHAR); 

(* Prints the message, does a pause, and HALTs. *) 

PROCEDURE assert(test:BOOLEAN; msg:ARRAY OF CHAR); 

(* If test Is FALSE, fatal Is called with msg. Else, nothing. *) 

PROCEDURE max(a, b:CARDINAL):CARDINAL; 

PROCEDURE min(a, b:CARDINAL):CARDINAL; 

END Mlsc. 


strIngst.mod 

Programming Project: "Build a Spreadsheet Program," by 
Jonathan Amsterdam. July, page 96. 


IMPLEMENTATION MODULE StrlngStuff; 


PROCEDURE charCap(ch:CHAR):CHAR; 

BEGIN 

IF (ch >- 'a*) AND (ch <« ‘z') THEN 
RETURN CAP(ch); 

ELSE 

RETURN ch; 

END; 

END charCap; 

PROCEDURE strlngCap(VAR s:ARRAY OF CHAR); 

VAR I:CARDINAL; 

BEGIN 

FOR l 0 TO stringLen(s) DO 
s[ l ] :« charCap(s[I]); 

END; 

END strlngCap; 

PROCEDURE strlngLen(VAR s:ARRAY OF CHAR):CARDINAL; 

VAR i:CARDINAL; 

BEGIN 

FOR I :« 0 TO HIGH(s) DO 
IF s[I] - 0C THEN 
RETURN I; 

END; 

END; 

RETURN HIGH(s)+1; 

END strIngLen; 

PROCEDURE strIngAssign(VAR destrARRAY OF CHAR; sourcerARRAY OF CHAR); 
VAR I:CARDINAL; ' 

BEGIN 

i := 0; 

LOOP 

IF I > HIGH(dest) THEN 
EXIT; 

ELSIF I > HIGH(source) THEN 
dest[I] := 0C; 

EXIT; 

ELSE 

dest[I] := sourcefi]; 

END; 

INC(I); 

END; 

END strIngAssIgn; 

PROCEDURE strlngCopy(VAR dest, sourcerARRAY OF CHAR; from, to:CARDINAL); 
VAR I, num:CARDINAL; 

BEGIN 

IF from <« to THEN 
num :* to-from+1; 

FOR I :■ 0 TO num-1 DO 

IF I > HIGH(dest) THEN 
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RETURN; 

ELSIF i+from > HIGH(source) THEN 
dest[i] :« 0C; 

RETURN; 

ELSE 

dest[l] :« source[i+from]; 

END; 

END; 

IF num <= HIGH(dest) THEN 
dest[num] :* 0C; 

END; 

ELSE 

dest[0] 0C; 

END; 

END stringCopy; 

PROCEDURE stringEqual(si, s2:ARRAY OF CHAR):BOOLEAN; 

VAR I:CARDINAL; 

BEGIN 

FOR i 0 TO HIGH(sl) DO 
IF i > HIGH(s2) THEN 
RETURN si[I] - 0C; 

ELSIF sl[l] <> s2[I] THEN 
RETURN FALSE; 

ELSIF s 1 [ 1] - 0C THEN 
RETURN TRUE; 

END; 

END; 

RETURN TRUE; 

END stringEqual; 

PROCEDURE deIeteChar(VAR s:ARRAY OF CHAR; pos:CARDINAL); 

VAR i-.CARDINAL; 

BEGIN 

FOR I :« pos TO HIGH(s)-1 DO 
s[i] s[i+1]; 

END; 

END deleteChar; 

PROCEDURE InsertChar(ch:CHAR; VAR s:ARRAY OF CHAR; pos:CARDINAL); 

VAR i:CARDINAL; 

BEGIN 

FOR I stringLen(s)-1 TO pos BY -1 DO 
s[1+1] :■ s[i]; 

END; 

s[pos] :* ch; 

END InsertChar; 

PROCEDURE findChar(s:ARRAY OF CHAR; ch:CHAR; VAR pos;CARDINAL):BOOLEAN; 
VAR 1, Ien;CARDINAL; 

BEGIN 

len :■ stringLen(s); 

IF len * 0 THEN 
RETURN FALSE; 

ELSE 


FOR I :« 0 TO len-1 DO 
IF s[i] - ch THEN 
pos :« I; 
RETURN TRUE; 

END; 

END; 

RETURN FALSE; 

END; 

END findChar; 

BEGIN 

END StrlngStuff. 
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vi $c.bos 

"Small-Scale Engineering Applications," by J. Nell 
Stone. July, page 253. 


10 REM ESTIMATE VISCOSITY - May 85 - VISC/BAS 
20 REM Final, Sept 2nd, 1985 
30 REM Edited for BYTE Dec 85 
40 GOTO 160 


70 DATA" 
80 DATA" 
90 DATA" 
100 DATA" 


50 DATA"****** VISCOSITIES ******" 

60 DATA"* OF LIQUIDS AND MIXTURES *" 

by" 

J.NeiI Stone" 

Ledge Engineering Inc" 

179 Lansdowne Avenue" 

110 DATA" Kingsville, Ontario, N9Y 3J2" 

120 DATA" " 

130 DATA" **** May 1985 ***♦" 

140 CLS:FOR J-1 TO 9:READ Y:PRINT@ FN LC(NR/2-5+J,NS/2-17),Y:NEXT 

150 RETURN 

160 CLEAR 1500 

170 DEFINTJ-L,N:DEFSTRX-Z 

180 DIM 

Y,J,K,NS,KP,Y%,LC,KQ,AT,KC,N,UT,A,J9,ET,TR,TL,J8,J$,KS,RD,NL,NC,F2,NR,V,NM 
’simple vars 

190 POKE 16409,1 ’Set caps mode 

200 NS=64:NR«16:LF»1 'screen parameters for TRS80 


210 ’NS*80:NR«24:LF-128 ’screen parameters for 80x24 (IBM) 

220 DEF FN LC(J,K)«(J-1)*NS+K-1 
230 GOSUB 50 ’display title 

240 DIM A(2,92),AX(10),AY(10),YT(8),Y(8),AV(10),AM(10),YN(10),YM(3),MC(10) 
’arrays 

250 REM Set up message strings 

260 Y(1)«"MoI ecu I or weight":Y(2)«"Cr11lea I temp, K":Y(3)-"Crtt!cal press, 
atm“:Y(4)-"Crltlcal vol, cc/moP:Y(5)*»"Acentrlc factor":Y(8)="MeItIng point, 
deg C":Y(6)-"Denslty. g/cc (SG)":Y(7)-"Temp. of density measure, deg C" 

270 YM(1)»"Przezdziecki 4 Sridhar":YM(2)-"StieI 4 Thodos":YM(3)«"AIChE Data 
Prediction Manual" 


280 Z-:Z1«CHR$(91)+CHR$(10)+CHR$(13)+"Xx"+CHR$(9):Z3-" ":Z4-"<~ 

":Z6-".-0123456789":Z2-Z6+Z1:Z5-Z6+"ED+"+CHR$(13)+CHR$(8) 

290 Z8-“USE UP. DOWN, RT ARROWS TO SELECT ENTRY. <X> TO EXIT.“:Z9-"USE "+Z4+" 
TO CORRECT. PRESS <ENTER> WHEN DONE":ZC-STRING$(17.“ ") 

300 Y1-"###.##":Y2-"#ii(#":Y3."##.####":Y4="####.####•• ;Y5="##.####-- 

310 REM Set up constants 

320 C1-273.16:C2-2/7:C3-1E-10 

330 ON ERROR GOTO 7190 

340 GOTO 1000 * to main prog 

390 REM All-purpose screen for 1,2 or 3 col numeric entry 

400 REM Screen layout 

410 CLS:PRINT TA8((NS-LEN(ZA))/2) ZA 

420 PRINT STRING$(NS-1,"=") 

430 FOR J=1 TO NT:J$=RIGHT$(STR$(J),1) 

440 PRINT YT(J); 

450 IF INSTR(ZD,J$) THEN PRINT:GOTO 490 ELSE IF INSTR(ZG,J$) THEN 480 
460 IF J8>2 THEN PRINT TAB(NS-46);A(0,KS+J-1); 

470 IF J8>1 THEN PRINT TAB(NS-30);A(1.KS+J-1); 

480 PRINT TAB(NS-14);A(2,KS+J-1) 

490 NEXT 

500 REM Display data os SP to prevent overflows 
510 PRINT® FN LC(14,1),STRING$(NS-1,95) 

520 PRINT® FN LC(15,1),CHR$(30);ZB; 

530 REM Begin display 

540 KQ«NS-17:KP=KL+1:J9*6:GOTO 600 

550 PRINT® FN LC(KP+1,KQ+1),Z; 

560 PRINT® FN LC(16,1),CHR$(30);Z8; 

570 Y$=*INKEY$: IF Y$-"“ THEN 570 
580 IF INSTR(Z2,Y$)=0 THEN 570 
590 J9-INSTR(Z1,Y$) 

600 IF J9=0 THEN 760 ELSE PRINT® FN LC(KP+1,KQ+1),Z3; 

610 ON J9 GOTO 640,620,620,630,630,670 
620 J9=1:GOTO 650 
630 RETURN 
640 J9—1 


650 KP-KP+J9:IF KP>KM+1 THEN KP=KL+1 ELSE IF KP<KL+1 THEN KP-KM+1 
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660 GOTO 710 

670 ON J8 GOTO 710,700 

680 IF KQ-NS-49 OR KQ-NS-33 THEN KQ-KQ+16 ELSE KQ-NS-49 
690 GOTO 710 

700 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ-NS-33 
710 ZF-STR$(KP-1):ZF-RIGHT$(ZF,LEN(ZF)-1“ 

720 IF INSTR(ZO.ZF) THEN IF J9-6 THEN J9=1:GOTO 650 ELSE 650 
730 IF INSTR(ZG.ZF) THEN KQ-NS-17 
740 GOTO 550 

750 REM Data entry section 

760 PRINT®FN LC( 16,1),CHR$(30);Z9; 

780 PRINT®™ LC(KP+1,KQ+1),ZC;:PRINT@ FN LC(KP+1.KQ+5),ZE;CHR$(95); 

790 Y$-INKEV$:IF Y$-"" THEN 790 
800 YX-INSTR(Z5,Y$) : IF Y%-0 THEN 790 
810 IF YX>15 THEN ON Y%-15 GOTO 880,860 
820 KC-KC+1 

830 ZE=ZE+Y$ ^ ^ 

840 PRINT® FN LC(KP+1.KQ+KC+4),Y$;CHR$(95); 

850 GOTO 790 

860 KC-KC-1:IF KC<«0 THEN KC»0:ZE=“" ELSE ZE=LEFT$(ZE,KC) 

870 GOTO 780 

880 KE-(KQ-NS+49)/16 

890 A(KE,KP+KS-2)-VAL(ZE) , „ . 

900 PRINT® FN LC(KP+1,KQ+1),ZC;:PRINT@ FN LC(KP+1.KQ+4),CSNG(VAL(ZE)); 

910 ZE«"":J9-1 

920 IF KQ-NS-17 THEN KP-KP+1 
930 IF KP>KM+1 THEN KP-KL+1 
940 GOTO 670 
990 REM Main program 

1000 GOSUB 8000 ’introductory text 

1010 GOSUB 6620 ’title etc 

1020 GOSUB 6080 ’main menu 

1030 ON NM GOSUB 1250,1250,1500 ’goto correct routine 

1040 IF NC<>6 THEN 1060 

1050 ON ERROR GOTO 0:END ’end of program 

1060 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)«0:NEXTJ,K:LP«0 
1070 IF NC-5 THEN JP-0:LT-0 
1080 ON NC-3 GOTO 1020,1010 

1240 REM Viscosity prediction by both methods 

1250 IF NE THEN 1290 ’go to input if returned by error 

1260 GOSUB 8270 ’intro text 

1270 GOSUB 2000 ’name of substance 

1280 GOSUB 8550 'load data from file. If any 

1290 GOSUB 2030 ’enter phys props 

1300 GOSUB 2150 ’calc for substance 

1310 GOSUB 6170 ’calculation options 

1320 IF TN-0 THEN G0SU8 2360:GOSUB 4500 ELSE G0SU8 2500 

'calc for temp of interest 

1330 GOSUB 6400 ’what next 

1340 ON NC GOTO 1360,1310,1370 

1350 RETURN 

1360 CLS:GOSUB 5000:GOTO 1330 

1370 FOR K-0 TO 2:F0R J-1 TO 8:A(K,J)-0:NEXTJ,K:LP-0:GOTO 1270 
1490 REM Mixture routine 

1500 IF NE THEN 1540 ’to entry If return on error 
1510 GOSUB 8470 'intro blurb 

1520 GOSUB 3000 ’get names of materials 

1530 IF NL-2 THEN GOSUB 3120 ’range of calcs? 

1540 GOSUB 3250 ’data in 

1550 GOSUB 3490 ’estimate missing viscosities 

1560 GOSUB 3750 'viscosity of mixture/print 

1570 GOSUB 6510 ’what next? 

1580 ON NC GOTO 1610,1530,1650 
1590 RETURN 

1600 REM Hardcopy results „ M1B 

1610 IF AL THEN CLS:PRINT"Too latel Cannot print results for range now.":GOSUB 
7070:GOTO 1570 

1620 CLS:GOSUB 5410 ’hardcopy results 

1630 GOTO 1570 

1640 REM Clean out data 

1650 AL-0:FOR J-1 TO NL:FOR K-0 TO 2:A(K,J)-0:NEXT K,J:GOTO 1520 
1990 REM Input material data 
2000 CLS:KS-1 

2010 INPUT"Nome of Substance";YB 


(continued) 
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2020 RETURN 

2030 CLS:NE-0 'reset error flog 

2040 KS-1 :KL-1 :KM-8:ZA-"PROPERTIES OF "+YB 

2050 ZB-" *: ZD-" ": ZG-" ": J8-1 

2060 IF NM-2 THEN KM-7 'no f. pt needed for St 4 Th 

2070 FOR J-1 TO KM:YT(J)-Y(J):NEXT 'Instol titles 

2080 NT-9-NM 'no of titles 

2090 GOSUB 410 'to doto Input 

2100 GOSUB 2600 'check Input doto volld 

2110 IF NE THEN NE«0:GOTO 2090 ELSE GOSUB 8850 

2120 


MW-A(2,1):TC-A(2,2):PC-A(2,3):VC-A(2,4) 
,7)+C1 'get doto In equation variables 
2130 RETURN 


:W-A(2,5):TF-A(2,8)+C1:SG-A(2,6):TD-A(2 


2140 REM Calculate basic parameters 
2150 CLS 

2160 TR-TD/TC:FZ-.29056-.08775+W 'Yamada 4 Gunn, 1973 

2170 GOSUB 2290 

2180 VS-MW/SG/F2 'calc scaling factor 

2190 IF NM-2 THEN GOTO 2320 'Stiel and Thodos 

2200 REM Pr and Sr method 

2210 TR-TF/TC 

2220 GOSUB 2290 

2230 VM-F2+VS 

2240 VZ-.0085*TC*W-2.02+VM/(•342+TR+.894) 

2250 F1-4.27+.032*MW-.077+PC+.014*TF-3.82*TR 

2260 B-.33+VC/F1 - 1.12 

2270 RETURN 

2280 REM Calc f2(t) 

2290 F2«FZ~((1-TR)~C2) 'Yamada 4 Gunn 1973 
2300 RETURN 

2310 REM Stiel and Thodos parameter 
2320 ES-TC*(1/6) 

2330 ES-ES/SQR(MW)/(PC-(2/3)) 

2340 RETURN 

2350 REM Calc for specific temp 
2360 TR-(Tl+C1)/TC 
2370 GOSUB 2290:V-F2*VS 

2380 IF NM-2 THEN GOTO 2420 'to Stiel and Thodos 
2390 ET-B*(V/VZ-1):ET-1/ET 
2400 GOTO 2480 

2410 REM Stiel and Thodos calc 

2420 IF TR<1.5 THEN U8-34E-05*(TR~.94) ELSE UB=17.78E-05*((4.58*TR- 
1.67)*(5/8)) 'calc low press vise 
2430 RD-VC/V 

2440 UT-(((.0093324+RD-.040758)*RD+.058533)*RD+.023364)*RD+.1023 

2450 UT-UT*UT*UT*UT 

2460 UT-UT-1E-04+UB 

2470 ET-UT/ES 

2480 RETURN 

2490 REM Calc for range of temps 
2500 CLS 

2510 FOR TL-TS TO TE STEP TN 
2520 GOSUB 2360 
2530 GOSUB 5170 
2540 GOSUB 4650 
2550 NEXT 

2560 TL-TL-TN 'restore last temp calc’d 

2570 IF N THEN GOSUB 7070 
2580 RETURN 

2590 REM Check validity of Input data 
2600 FOR J-KS TO KS+5 
2610 IF A(2,J)>0 THEN 2630 

2620 CLS:PRINT Y(J-KS+1);" cannot be zero or negative.“:NE=1 
2630 NEXT 

2640 IF NE THEN PRINT:PRINT"Program will return to data entry. Please correct 
Input.":GOSUB 7070 3 

2650 RETURN 

2990 REM Initial Input for mixtures 
3000 CLS:JP-0 

3010 NL-0 * intialise - NL no of comps 

3020 NL-NL+1:YN(NL)-"":MC(NL)-0:PRINT "Nome of component no:";NL "- just 
<ENTER> If no more componentsINPUT YN(NL) 

3030 IF YN(NL)<>“" THEN IF NL<10 GOTO 3020 

3040 NL-NL-1:IF NL<2 THEN PRINT "Must have at least two components.":GOTO 3020 
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3060 PRINT "Are your compositions in wt% or mol% - type <W> or <M>" 

3070 YR="WwMm":G0SUB 7040 

3080 MX=(KA>2) ’mx true if mol% 

3090 IF MX THEN YU-"molX" ELSE YU-"wtX" 

3100 RETURN 

3110 REM Calculate for range 

3120 CLS:AL-0:MP*0:PRINT "Do you want to automatically calculate viscosities 
for a rangeof compositions Y/N?" 

3130 GOSUB 7030 
3140 IF KA>2 THEN 3230 

3150 PRINT "Minimum value of ";YU" for ";YN(1);:INPUT AL 

3160 IF (AL<0) OR (AL>100) THEN PRINT YU;"must be in range 0-100":GOTO 3150 
3170 PRINT "Maximum value of ";YU" for ";YN(1);:INPUT AH 

3180 IF (AH<0) OR (AH>100) OR (AH<AL) THEN PRINT YU;"must be in range 0-100 

and max must be bigger than min.":GOTO 3170 

3190 PRINT "Increments of “;YU" for ";YN(1);:INPUT AD 

3200 PRINT:PRINT "Do you want hardcopy of the results as they are done, Y/N?" 
3210 GOSUB 7030 

3220 MP=(KA<3) ‘true if hardcopy needed 
3230 RETURN 

3240 REM Initial data entry for mixtures 

3250 FOR J=1 TO NL:IF LEN(YN(J))>NS-51 THEN YT(J+1)-LEFT$(YN(J).NS-51) ELSE 
YT(J+1)=YN(J) 

3260 NEXT 

3270 YT(1)-STRING$(NS-46," ")+"Visc - cp"+STRING$(7," ")+"Mol.Wt"+STRING$(10," 
")+YU 

3280 ZA-"MIXTURE VISCOSITY INPUT DATA" 

3290 ZB-"LEAVE ANY UNKNOWN DATA AS 0 - MW NOT NEEDED IF USING MOL%" 

3300 ZD-"1.":ZG-"":J8-3:NT«NL+1:KL-2:KM-NL+1:KS«0 
3310 IF AL THEN A(2,1)-AL:A(2,2)-100-AL 
3320 GOSUB 410 'screen routine 

3330 GOSUB 3390 'check data 

3340 IF NE THEN NE-0:GOTO 3320 'return if data check not OK 

3350 FOR J-1 TO NL:AV(J)«A(0,J):AM(J)=A(1,J):AX(J)-A(2,J):NEXT 'put data into 

working vars; ov-vlsc,om«mw,ax=frn 

3360 TL—1000 'flag to show temp not set 

3370 RETURN 

3380 REM Check screen input for mixtures 
3390 CLS:NE-0:A=0 


3400 FOR J-1 TO NL 

3410 IF NOT MX THEN IF A(1,J)<=0 THEN PRINT"MoI ecu I or wt for ";YN(J); M 


required":NE»1 

3420 IF NL<>2 OR AL-0 THEN 


IF A(2,J)<0 OR A(2,J)>100 THEN PRINT YU;" 


of 


";YN(J); M out of range":NE-1 
3430 A-A+A(2,J) 

3440 NEXT 

3450 IF A>100 OR A<100 THEN PRINT"Components do not odd to 100 ";YU:NE-1 


3460 IF NE THEN GOSUB 7070 
3470 RETURN 

3480 REM Estimate viscosity of missing items 

3490 CLS:NK-0 'nk is temperature flag 

3500 FOR LM-1 TO NL 'Im is main counter 

3510 IF AV(LM) THEN 3720 'skip if vise given 

3520 MC(LM)=1:PRINT "Estimating viscosity of ";YN(LM) 

3530 PRINT:PRINT "Is ";YN(LM):PRINT "a non-ossociating compound, Y/N?"; 

3540 GOSUB 7030 

3550 IF KA<3 THEN NM-1 ELSE NM-2 

3560 YB-YN(LM):KS-LM*8+4:A(2,KS)=AM(LM):GOSUB 8550 'check for dato on disk 
3570 CLS:NE=0 'reset error flag 
3580 KL-1:KM=8:ZA»"PROPERTIES OF "+YB 
3590 ZB-"":ZD-"":ZG-"":J8-1 

3600 IF NM-2 THEN KM-7 'no f. pt needed for St 4 Th 

3610 FOR J-1 TO KM:YT(J)-Y(J):NEXT 'install titles 

3620 NT-9-NM 'no of titles 

3630 GOSUB 410 'to data Input 

3640 GOSUB 2600 'check input data valid 

3650 IF NE THEN NE-0:GOTO 3630 ELSE GOSUB 8850 


MW»A(2,KS):TC-A(2,KS+1):PC-A(2,KS+2):VC»A(2,KS+3):W-A(2,KS+4):TF-A(2,KS+7)+C1: 
SG»A(2,KS+5):TD-A(2,KS+6)+C1 'get dato in equation variables 
3670 GOSUB 2150 ’start calculation 

3680 CLS:IF NK-0 THEN NK-1:INPUT "Temperature of estimote, deg C.";TL 
3690 GOSUB 2360 

3700 AV(LM)-ET:A(0,LM)-CSNG(ET) ’sove answer 

3710 CLS:PRINT "Viscosity of ";YN(LM);" calculated":GOSUB 7010:NM-3 


[continued) 
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3720 NEXT 
3730 RETURN 

3740 REM Calculate vise of mixture 
3750 IF AL THEN GOTO 3790 

3760 IF NOT MX THEN GOSUB 3890 *conv to moles if nec 

3770 GOSUB 3960 'calculate mixture vise 

3780 GOTO 3860 'to return 

3790 N-0:FOR A-AL TO AH STEP AO 

3800 AX(1)-A:AX(2)-100-A 

3810 IF NOT MX THEN GOSUB 3890 

3820 GOSUB 3960 

3830 IF MP THEN GOSUB 5570 

3840 GOSUB 4730 

3850 NEXT 

3860 IF NL>2 OR AL-0 THEN GOSUB 4550 ELSE IF N THEN GOSUB 7070 'to screen if 
results requ’d 
3870 RETURN 

3880 REM Convert to mole frn 

3890 AT=0:FOR J-1 TO NL 

3900 AY(J)«AX(J)/AM(J):AT-AT+AY(J) 

3910 NEXT 

3920 FOR J-1 TO NL 
3930 AX(J)«AY(J)*100/AT 
3940 NEXT:RETURN 
3950 REM Vise of mixture 
3960 AT-0 

3970 FOR J-1 TO NL 

3980 AT-AT+AX(J)*LOG(AV(J)) 

3990 NEXT 

4000 ET-EXP(AT/100) 'viscosity of mixture 
4010 RETURN 

4490 REM Print results 
4500 CLS 

4510 PRINT "Viscosity of ";YB;“ at“;:PRINT USING “ ###.# deg C is ###.### 
cp";TL,ET 
4520 PRINT 
4530 RETURN 

4540 REM Screen print for mixture 
4550 CLS 

4560 PRINT "Viscosity of mixture of:" 

4570 FOR J-1 TO NL 

4580 PRINT TAB(5) USING Y1;A(2,J)::PRINT" ";YU;“ ";YN(J) 

4590 NEXT V ' 


4600 PRINT: IF TLo-1000 THEN PRINT "at "; TL; " deg C": 

4610 PRINT " is";:PRINT USING Y3;ET;:PRINT " cp" 

4620 GOSUB 7070 
4630 RETURN 

4640 REM Screen print list of results 
4650 IF TLoTS AND N<>0 THEN 4680 
4660 N-0:PRINT "Viscosity of ";YB 

4670 PRINT TAB(5) "Temperature, deg C";TAB(NS-25)"Viscosity, cp" 
4680 PRINT TAB(12) USING Y2;TL;:PRINT TAB(NS-23) USING Y4;ET 
4690 N-N+1 


4700 IF N=NR-4 THEN GOSUB 7070:N=0:CLS 
4710 RETURN 


4720 REM Screen display list of mixture results 
4730 IF AoAL AND N<>0 THEN 4760 'jump titles if not 
4740 CLS:N=0:PRINT TAB(12);YU;" of";TAB(54)"Viscositv" 
4750 PRINT YN(1);TAB(25) YN(2);TAB(58)"cp" 

4760 PRINT USING Y1;A; 

4770 PRINT TAB(25) USING Y1;100-A; 

4780 PRINT TAB(56) USING Y3;ET 
4790 N-N+1 


first time 


4800 IF N=NR-4 THEN GOSUB 7070:N-0 
4810 RETURN 

4990 REM Hardcopy results 

5000 IF TN THEN CLSrPRINT "Too late! Cannot print results for ranae 
now.GOSUB 7070:GOTO 5150 9 

5005 GOSUB 6000 


5010 CLS:ON JP GOTO 5020,5090 
5020 GOSUB 5290:GOSUB 5330 
5030 LPRINT 

5040 LPRINT TAB(5) "viscosity of 
5050 LPRINT:LPRINT TAB(25) USING 
5060 LPRINT:LPRINT 
5070 GOTO 5150 


“:YB;" estimated by method of ";YM(NM); 
Y4+" cp at "+Y2+" deg C";ET,TL 


is: 
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5080 REM Table heading 

5090 IF LT THEN 5140 ’LT is flog for table 
5100 GOSUB 5290 

TAB(5)"Substance";TAB(25)"Temperature";TAB(40)"Viscosity";TAB(52)"Method" 
5120 LPRINT TAB(30)"deg C";TAB(44)"cp" 

5130 LPRINT:LT«1 . . 

5140 LPRINT TAB(5)YB;:LPRINT TAB(29) USING Y2;TL;tLPRINT TAB(40) USING 
Y4;ET;:LPRINT TAB(52) YM(NM) 

5150 RETURN 

5160 REM List results for temp range on printer 


5170 IF LP-0 THEN 5270 
5180 IF TLoTS THEN 5250 
5190 GOSUB 5290:GOSUB 5330 

5200 LPRINT TAB(5)"EstImated viscosities using method 
5210 LPRINT , „ 

5220 LPRINT TAB(10)"Temperature";TAB(45)“Viscosity" 
5230 LPRINT TAB(13)"deg C";TAB(49)"cp" 

5240 LPRINT , v 

5250 LPRINT TAB(14) USING Y2;TL;:LPRINT TAB(45) USING 
5260 IF TL+TN>TE THEN LPRINT 
5270 RETURN 

5280 REM Print heading 

5290 LPRINT TAB(5)"Project: “;YP;TAB(55)YD 


of ";YM(NM) 


Y4;ET 


5300 LPRINT 
5310 RETURN 


5320 REM Input data print 

5330 LPRINT TAB(5)"INPUT DATA for “;YB 

5340 LPRINT 

5350 FOR J-1 TO 9-NM 

5360 LPRINT TAB(10) Y(J); -.LPRINT TAB(45) USING Y4;A(2,J) 


5370 NEXT 
5380 LPRINT 
5390 RETURN 

5400 REM Hardcopy for mixtures 
5410 GOSUB 5290 

5420 LPRINT TAB(40)"INPUT DATA":LPRINT 

5430 LPRINT TAB(5)"Substance";TAB(35)"Visc - cp";TAB(48)"Mol. wt";TAB(63)YU 

5440 FOR J-1 TO NL 

5450 LPRINT TAB(5) YN(J); 

5460 LPRINT TAB(35) USING Y3;AV(J); 

5470 IF MC(J) THEN LPRINT"*"; 

5480 LPRINT TAB(48) USING Y1;AM(J); 

5490 LPRINT TAB(61) USING Y1;A(2.J) 

5500 NEXT 

5510 LPRINT:LPRINT TAB(10) "* means estimated value, not input" 

5520 LPRINT:LPRINT TA8(5) “Viscosity of mixture"; 

5530 IF TLo-1000 THEN LPRINT" at";TL;" deg C"; 

5540 LPRINT" ls";:LPRINT USING Y3;ET;:LPRINT" cp.":LPRINT 
5550 RETURN 

5560 REM Table of mixture viscosities 

5570 IF AoAL THEN 5700 ’only print title first time 

5580 GOSUB 5290 

5590 LPRINT:LPRINT TAB(5) "Viscosities of mixtures of:" 

5600 LPRINT:FOR J-1 TO 2 
5610 LPRINT TAB(10);YN(J) 

5620 NEXT 
5630 LPRINT 

5640 IF TLo-1000 THEN LPRINT TAB(5)" at";TL; B deg C "; 

5650 LPRINT TAB(5) "are as follows:" 

5660 LPRINT:LPRINT TAB(17);YU;" of "; 

5670 LPRINT TAB(55)"Viscosity" 

5680 LPRINT TAB(5);YN(1);TAB(30);YN(2);TAB(58)"cp" 

5690 LPRINT 

5700 LPRINT TAB(5) USING Y1;A;:LPRINT TAB(30) USING Y1;100-A; 

5710 LPRINT TAB(55) USING Y3;ET 
5720 IF A+AD>AH THEN LPRINT 
5730 RETURN 


5990 REM Hardcopy option menu 
6000 CLS:IF JP-2 THEN 6060 

6010 PRINT® FN LC(1,(NS-7)/2),"PRINT OPTIONS" 

6020 PRINT:PRINT TAB(5)"l) Print Just the current result complete with input 
data* 1 

6030 PRINT TAB(5)"2) Print table heodlngs and start table for all":PRINT 
TAB(8)"resuIts until new project is started." 


(continued) 
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6040 NC-2:G0SUB 7120 

6050 JP«NC * JP ■* flag for choice 

6060 RETURN 


6070 REM Main menu 
6080 CLS 

6090 PRINT® FN LC(1 # ( NS-4J/2)."MAIN MENU" 


non-associating liquid - most 


6100 PRINT:PRINT TAB(5)"l) Viscosity of 
accurate" 

6110 PRINT JAB(5)"2) Viscosity of associating liquid — not very accurate" 
Viscosity of liquid mixture" 

7120 


6120 

6130 

6140 

6150 


PRINT TAB(5 
NC-3:GOSUB 
NM-NC 
RETURN 


6160 

6170 

6180 

6190 

6200 

6210 

6220 

6230 

6240 

6250 

6260 

6270 

6280 

6290 

6300 

6310 

6320 

6330 

6340 

6350 

6360 

6370 

.6380 


REM Calculation options 
CLS 

PRINT® FN LC(1,fNS-10)/2),"CALCULATION OPTIONS" 

PRINT:PRINT TAB(5)"1) Estimate viscosity for one specific temperature 
PRINT TAB(5)"2) Estimate viscosity for a range of temperatures" 

PRINT 

NC=2:GOSUB 7120 
TN»0 

ON NC GOTO 6370 

CLS:INPUT"Start of temperature range, deg C";TS 
INPUT"End of temperature range, deg C";TE 
INPUT"Temperature interval in range, deg C";TN 
PRINT:PRINT "Everything correct, Y/N? 

GOSUB 7030 
IF KA>2 THEN 6250 

CLS:PRINT "Do you want results tabulated on printer. Y/N? " 

GOSUB 7030 
LP-(KA<3) 

IF LP THEN PRINT "Press <ENTER> when printer is ready" ELSE 6380 
Y*INKEY$:IF Y«"" THEN 6350 
GOTO 6380 

CLS:INPUT"Temperature, deg C";TL 
RETURN 


6390 REM Menu after calc 

6400 PRINT TAB((NS-4)/2),"WHAT NEXT" 

6410 PRINT 


6420 PRINT TAB(5)"1) Hardcopy of result (one result only)." 

6430 PRINT TABf5 V'2) Viscosity for same material at another temperature." 
6440 PRINT TAB(5)"3) Viscosity for different substance of the same type!" 
6450 PRINT TAB(5V'4) Main menu." 

6460 PRINT TAB(5)"5) New project (all data lost) " 

6470 PRINT TAB(5)"6) End program." 

6480 NC=6:GOSUB 7120 
6490 RETURN 


6500 REM Menu after mix 

6510 PRINT TAB((NS-4)/2),"WHAT NEXT" 

6520 PRINT 

6530 PRINT TAB(5V'1} Hardcopy of results" 

6540 PRINT TABC5)"2) Another calculation for same materials." 
6550 PRINT TAB(5)"3) Calculate for a different mixture." 

6560 PRINT TAB(5)"4; Main menu." 

6570 PRINT TAB(5)"5) New project (all data lost)." 

6580 PRINT TAB(5)"6) End program." 

6590 NC*6:GOSUB 7120 
6600 RETURN 


6610 REM Project intro routine 

6620 CLS:INPUT"Enter project title";YP 

6630 YD«LEFT$(TIME$,8):PRINT "Project date (default « ";YD;")"::INPUT YD 
6640 RETURN * ' * ' 

6990 REM Subroutines 
7000 REM Delay 

7010 FOR J-1 TO 1000:NEXT:RETURN 
7020 REM Check Inkey 
7030 YR»"YyNn" 

7040 Y-INKEY$:IF Y-"" THEN 7040 

7050 KA-INSTR(YR.Y):IF KA THEN RETURN ELSE 7040 

7060 REM Press key to cont 

7070 PRINT® FN LC(NR,1),"PRESS ANY KEY TO CONTINUE"; 

7080 Y-INKEY$:IF Y-"" THEN 7080 
7090 CLS 
7100 RETURN 

7110 REM Select from menu 

7120 PRINT:PRINT"Choose by number" 
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7130 Y-INKEY$:IF Y- M " THEN 7130 
7140 YX-VAL(Y) 

7150 IF Y%<1 OR YX>NC THEN 7130 
7160 PRINT Y:NC-Y% 

7170 RETURN 

7180 REM Error trap 

7190 CLS 

7200 IF ERR/2+1-5 THEN 7250 
7210 IF ERR/2+1-11 THEN 7290 
7220 IF ERR/2+1-54 THEN 7360 
7230 IF ERR/2+1-6 THEN 7270 

7240 PRINT "Error In Iine";ERL:ON ERROR GOTO 0:RESUME 

7250 PRINT "Illegal function call error has occurred in Iine";ERL:GOSUB 7340 
7260 PRINT "Look for negative or zero values of input data":GOTO 7310 
7270 PRINT "Overflow error has occurred In Iine";ERL:GOSUB 7340 
7280 PRINT "Look for very low or very high values of input data":GOTO 7310 
7290 PRINT "Division by zero error has occurred in Iine";ERL:GOSUB 7340 
7300 PRINT "Look for very low or zero values of input data" 

7310 PRINT "Check that input data units are correct, and that all values 
orewithln the range of the correlation" 

7320 GOSUB 7070:NE-1 *ne is error flag 
7330 RESUME 1030 

7340 PRINT "Program will return to data entry to allow you to checkvalidity of 
your Input data" 

7350 RETURN 

7360 PRINT "No such file" 

7370 GOSUB 7070:CLOSE:JF-1:RESUME NEXT 
7990 REM Introductory blurb 
8000 CLS 

8010 GOSUB 8220:IF NB THEN 8200 

8020 CLS:PRINT “This program estimates viscosities of pure liquids and 
mixtures" 

8030 PRINT:PRINT "The viscosities of pure, non-associating, liquids are 
estlmotedby the method of J.W.PrzezdzieckI and T.Sridhar publishedin the 
AIChEJ, Feb. 1985, p333. It is the most accurate methodand should be used if 
possible." 

8040 PRINT:PRINT "Data required for the estimate are the molecular weight, 
thecrfttcal properties, the acentric factor, and at least onevalue of density 
at a known temperature." 

8050 PRINTrPRINT "This method gives estimates with an average error of 9%, and 
amaximum error of 40X, but results are very unreliable if usedfor associating 
liquids." 

8060 PRINT:GOSUB 7070 
8070 CLS 

8080 PRINT“For associating liquids there is really no reliable 
predictivemethod." 

8090 PRINT:PRINT "The method used in this program is that of Stiel and 
Thodos,as described in ’The Properties of Gases and Liquids’ byReid and 
Sherwood, 2nd Ed., p437.“ 

8100 PRINT:PRINT "Data required for the estimate are the molecular weight, 
thecritlcal properties, the acentric factor, and at least onevalue of density 
at a known temperature." 

8110 PRINT:PRINT "This method gives quite large errors (as much as - 

80%),usually on the low side, for some associating liquids, but noother method 

is any more accurate." 

8120 PRINT:GOSUB 7070 
8130 CLS 

8140 PRINT "Prediction of viscosities for liquid mixtures from purecomponent 
data is also rather unreliable." 

8150 PRINT'.PRINT "The method used in this program is procedure 8H from the 
AIChE’Data Prediction Manual’. It is appropriate for systems wherethe 
mixtures have viscosities intermediate between those of thecomponents." 

8160 PRINT:PRINT "Data required for the estimate are either the viscosities 
ofthe components, or the data listed previously to allow them tobe 
estimated."; 

8170 PRINT "Liquid compositions may be entered in moIX or wtX.but in the 
latter case the molecular weight is also required." 

8180 PRINT:PRINT "This method Is not suitable for systems that have maxima 
ormlnima in the mixture properties." 

8190 GOSUB 7070 
8200 RETURN 

8210 REM Routine to bypass blurbs 

8220 PRINT "This program Includes explanatory text and InstructIons.If you are 
familiar with the program, you can bypass these.Do you want Instructions 
displayed for this run, Y/N?" 

(continued) 
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8230 GOSUB 7030 

8240 NB»(KA>2) *nb is flag Indicating No Blurbs 
8250 RETURN 

8260 REM Blurb for Pic S method 
8270 CLS:IF NB THEN 8450 
8280 IF NM-2 THEN GOTO 8370 

8290 PRINT "This calculation method gives quite accurate results for most" 
8300 PRINT "non-associating compounds. Any errors tend to be on the low" 
8310 PRINT "side, and the errors are more pronounced at lower temperatures." 
8320 PRINT "reaching a maximum close to the freezing point." 

8330 PRINT:PRINT "The only common organics that cannot be handled are 
a I coho Is," 


8340 PRINT "both aliphatic and aromatic. Cyclic and branched compounds 
":PRINT"tend to give quite large errors, usually on the low side." 

8350 PRINT "Organic acids seem to be predictable." 

8360 GOTO 8440 
8370 CLS 

8380 PRINT "This calculation method gives reasonable results for many" 

8390 PRINT "compounds. It works best at temperatures from" 

8400 PRINT "the boiling point up, and the errors are more pronounced":PRINT 
"at lower temperatures." 

8410 PRINT "Only use this method for associating compounds." 

PRINTiPRINT "For all other substances, the Przezdziecki and Sridhar" 
PRINT "method is better." 


8420 

8430 

8440 

8450 

8460 

8470 

8480 


GOSUB 7070 
RETURN 

REM Blurb for mixtures 
IF NB THEN 8530 
CLS 

8490 PRINT "This section calculates 
viscosities of the pure components, 


the viscosity of liquid 
for up to 10component8.' 
viscosities are not 


mixturesfrom the 


known, they wiI I 


8500 PRINT:PRINT "If the pure component 

beestimated by one of the methods available. Leaving thevlscosity value as 
zero during data entry will automaticallyactlvate the estimating procedure." 
8510 PRINTiPRINT 'If there are only two components, a range of mixtures can 
becalculated automatically - you will be prompted for the rangeif this option 
is chosen." 


8520 GOSUB 7070 
8530 RETURN 

8540 REM Read data from file 
8550 CLS 

8560 PRINT"Checking disk for data..." 

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720 

8580 IF N>L0F(1)/LF THEN 8650 

8590 A(2,KS)-CVS(MF$):A(2,KS+1)«CVS(TF$) 

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)=CVS(VF$) 

8610 A(2.KS+4)=CVS(WF$):A(2,KS+5)=CVS(DF$) 

8620 A(2,KS+6)-CVS(SF$):A(2,KS+7)-CVS(FF$) 

8630 FOR J-1 TO 7:IF ABS(A(2,KS+J))<C3 THEN A(2,KS+J)=0 
8640 NEXT 
8650 RETURN 

8660 REM Open file for crit data 
8670 Y«LEFT$(YH,1)+"CRIT/DAT" 

8680 OPEN"R",1,Y,128 

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 
AS DF$,4 AS SF$,4 AS FF$,60 AS XF$ 

8700 RETURN 


8710 REM Find If name In record 
8720 N-1 
8730 GET 1,N 

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K- 

J)»STRING$(K-J," ") THEN 8760 

8750 N=N+1:IF N<=L0F(1)/LF THEN 8730 

8760 RETURN 

8770 REM Convert name to caps 
8780 YH-YB 

8790 FOR J-1 TO LEN(YB) 

8800 K»ASC(MID$(YB,J)) 

8810 IF K>96 AND K<123 THEN YL«CHR$(K-32):MID$(YH,J)=YL 
8820 NEXT 
8830 RETURN 

8840 REM Write data to disk 

8850 IF N<*LOF(1)/LF THEN LSET FF$«=MKS$(A(2,KS+7)):GOTO 8920 
8860 LSET NF$-YH 
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8870 LSET MF$=MKS$(A(2.KS)):LSET TF$=MKS$(A(2,KS+1)) 
8880 LSET PF$=MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3)) 
8890 LSET WF$=MKS$(A(2,KS+4)):LSET DF$=MKS$(A(2,KS+5)) 
8900 LSET SF$=MKS$(A(2,KS+6)):LSET FF$=MKS$(A(2,KS+7)) 
8910 LSET BF$*" 

8920 PUT 1,N 
8930 CLOSE 1 
8940 RETURN 


critical.bas 

"Small-Scale Engineering Applications," by J. Neil 
Stone. July, page 253. 


10 REM Predict critical props program - Apr 85 - CRITICAL/BAS 
20 REM Rummens & Rajan, Can.J.Ch.E., Jun 1979, 349 - general 
30 REM Edited for BYTE Dec 1985 
40 GOTO 170 


50 DATA"***** CRITICAL PROPERTY **♦**" 
60 DATA"** PREDICTION **" 


70 DATA" by" 

80 DATA" J.Neil Stone" 

90 DATA" Ledge Engineering Inc" 

100 DATA" 179 Lansdowne Avenue" 

110 DATA" Kingsville, Ontario, N9Y 3J2" 

120 DATA" " 

130 DATA" **** Apr 1985 ♦***" 

140 CLS:FOR J-1 TO 9:READ Y:PRINT@ FN LC(NR/2-5+J,NS/2-17),Y:NEXT 

150 RETURN 

160 REM Initialize 

170 CLEAR 500 

180 DEFINT J-L,N:DEFSTR R,X-Z 

190 DIM Y,K,J,M,TD,Y%,LF,KA 

200 POKE 16409,1 'Set caps mode 

210 NS«64:NR-16:LF-1 ’parameters for TRS80 

220 , NS-80:NR-24:LF«128 'parameters for 80x24 

230 DEF FN LC(J,K)«(J-1)*NS+K-1 

240 GOSUB 50 'display title 

250 DIM PB(3),E(2,11),Y(12),P(2),TR(2),F(1),V(2) ’arrays 
260 REM Set up message strings 

270 Y(1)="MoI ecu Iar we 1ght":Y(5)-"B.Pt.":Y(2)-Y(5)+" deg C":Y(3)-”SpecifIc 
gravity. 20/4“:Y(4)-" (opt)":Y(6)»"Vap.Press, ":ZZ(8)«"Density, 
g/cc”:Y(8)»"deg F":Y(9)»"deg C”:Y(10)«"mmHg":Y(11)-"psia":Y(12)-"kPa" 

280 Y1Y2="###.###“:Y3-"###.##" 

290 Z-“—>":Z1-CHR$(10)+CHR$(91)+CHR$(9)+CHR$(13)+"X"+"x":Z3-" ":Z4«".+- 

0123456789":Z2-Z4+Z1:Z5=CHR$(8)+CHR$(13)+"ED"+Z4 

300 Z8«"USE UP, DN. RT ARROWS TO SELECT ENTRY. <X> TO EXIT":Z9-"USE <-- TO 
CORRECT. PRESS <ENTER> WHEN DONE":ZA-STRING$(17," “) 

310 REM Set up constants 

320 C1-1.5:C2-36:C3-42:C4-35:C5-.3143:C6-.0838:C7-8.315E- 


03:C8«1.9:C9-.26:CA»2.38:CB=.2:CC-.489:CD«.225:CE-.511:CF«660:CG«.1:CH*1,8:CJ= 
32:CK-.10135:CL-760:CM-14.696:CN-1000:CP-273.16 


330 ON ERROR GOTO 6130 

340 GOTO 1500 ’to main program 

490 REM Screen routine - put titles in ZZ() 

500 CLS:PRINT® FN LC(1,(NS-LEN(RA))/2),RA 

510 PRINT STRING$(NS-1 

520 FOR J-KL TO KM 

530 IF J-7 THEN PRINT:GOTO 570 

540 IFJ-KL THEN PRINT TAB(5) ZZ(J) TAB(NS-14) E(2,J):GOTO 570 
550 PRINT TAB(5) ZZ(J); 

560 IF J>3 THEN PRINT TAB(NS-30) E(1,J) TAB(NS-14) E(2,J) ELSE PRINT 
570 NEXT 

580 PRINT® FN LC(NR-3,1),STRING$(NS-1,95) 

590 PRINT® FN LC(NR-2.1),CHR$(30);RB; 

600 KQ»NS-17:KP-KL+1:J9»3:GOTO 660 
610 PRINT® FN LC(KP+1,KQ+1).Z; 

620 PRINT® FN LC(NR-1,1),CHR$(30);Z8; 

630 Y$-INKEY$:IF Y$- M ” THEN 630 
640 IF INSTR(Z2,Y$)-0 THEN 630 
650 J9-INSTR(Z1,Y$) 

660 IF J9-0 THEN 800 ELSE PRINT® FN LC(KP+1,KQ+1),Z3;:ON J9 GOTO 


(continual 
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690,680,710,680 
670 RETURN 
680 J9-J9-3 

690 KP-KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL+1 THEN KP-KM+1 

700 GOTO 750 

710 ON J8 GOTO 750,740 

720 IF KQ-NS-49 OR KQ-NS-33 THEN KQ-KQ+16 ELSE KQ-NS-49 
730 GOTO 750 


740 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ-NS-33 
750 ZF-STR$(KP-1):ZF-RIGHT$(ZF,LEN(ZF)-1)+"," 

760 IF INSTR(RD.ZF) THEN IF J9-3 THEN J9»1:GOTO 690 ELSE 690 
770 IF INSTR(RE.ZF) THEN KQ-NS-17 
780 GOTO 610 

790 REM Dota entry section 

800 PRINT® FN LC(NR-1,1),CHR$(30);Z9; 

810 KC-1:ZE-V$ 

820 PRINT® FN LC(KP+1,KQ+1),ZA;:PRINT® FN LC(KP+1,KQ+1)+4.ZE;CHR$(95): 

830 Y$=INKEV$:IF Y$="" THEN 830 

840 IF INSTR(Z5.Y$)=0 THEN 830 

850 ON INSTR(Z5.Y$) GOTO 900,920 

860 KC-KC+1 

870 ZE-ZE+Y$ 


’introductory text 
'get title etc 
‘get initial info 
’input data 
'calculate critprops 
’results on screen 
‘What next? 


880 PRINT® FN LC(KP+1.KQ+1)+KC+3,Y$;CHR$(95); 

890 GOTO 830 

900 IF KC-0 THEN 830 ELSE KC-KC-1:IF KC-0 THEN ZE-"“ ELSE ZE-LEFT$(ZE.KC) 

910 GOTO 820 

920 KE-(KQ-NS+49)/16 

930 E(KE,KP-1)=VAL(ZE) 

940 PRINT® FN LC(KP+1,KQ+1),ZA;:PRINT@ FN LC(KP+1,KQ+1)+3.CSNG(VAL(ZE)); 
950 ZE-'"': J9-1 v v u 

960 IF KQ-NS-17 THEN KP-KP+1 
970 IF KP>KM+1 THEN KP-KL+1 
980 GOTO 710 
1490 REM Main program 
1500 GOSUB 6500 
1510 GOSUB 4610 
1520 GOSUB 3000 
1530 GOSUB 2000 
1540 GOSUB 2500 
1550 GOSUB 3500 
1560 GOSUB 4500 

1570 ON NC GOTO 1590,1600,1610,1610 
1580 CLS:ON ERROR GOTO 0:END 
1590 GOSUB 4000:GOTO 1560 ’to hardcopy routine 
1600 GOSUB 5000:GOTO 1560 'save to disk 

1610 FOR J—1 TO 2:F0R K—1 TO 8:E(J,K)—0:NEXTK,J 'clean out input array 
1620 ON NC-2 GOTO 1510,1520 y 

1990 REM Data input 
2000 CLS 

2010 RA-"INPUT DATA FOR "+YA 

2020 RB-"DATA FOR SECOND VAPOUR PRESSURE POINT OPTIONAL" 

2030 RD="2,3,7," 

2040 RE-“1, " 

2050 J8-2 

2060 KL-1:KM=8:0N JF GOTO 2080.2080,2090 
2070 E(1,4)=CK*CN:G0T0 2100 
2080 E(1,4)-CL:GOTO 2100 
2090 E(1,4)-CM 

2100 ZZ(1)-Y(1):ZZ(2)-STRING$(NS-36, '* ")+"VaIue"+STRING$(9," 
“)+"Temperature , ':ZZ(3)=STRING$(43." ")+YT:ZZ(4)-Y(5)+" 

"+YP+ M /“+YT:ZZ(5)=Y(6)+" "+YP:ZZ(6)-ZZ(5):ZZ(7)=" " 

2110 GOSUB 500 'to screen entry 
2120 M=E(2,1) 

2130 N-4 

2140 FOR J-0 TO 2 
2150 ON JF GOTO 2170,2180,2190 

2160 P(J)=E(1,J+N)/CN:T(J)-E(2,J+N)+CP:C-CN+CK:GOTO 2200 


& 


ESl'H+N^CK/CUTjJj-ECZ.J+Nj+CP^-CLrGOTO 2200 


E(1,J+N)*CK/CL: 


=(E(2.J+N)-CJ)/CH+CP:C-CL:GOTO 2200 


2170 P 
2180 P 

2190 P(J)“E(1,J+N)+CK/CM:T(J)-(E(2|J+N)-Cj)/CH+CP:C-CM 
2200 NEXT 
2210 SG-E(1,8):D-SG+CN 

2220 IF JF-2 OR JF-3 THEN T-(E(2,8)-CJ)/CH ELSE T-E(2.8) 
2230 T(3)-T+CP V ‘ 

2240 RETURN 
2490 REM Calculation 
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2500 CLS 

2510 PRINT M CoIcuI ating" 

2520 IF P(2)=0 THEN N-0 ELSE N-1 

2530 IF P(0)=0 THEN GOSUB 2710 ELSE TB=T(0):TD-T(0) 

2540 T1-C1*TD 
2550 FOR J-0 TO 1 
2560 TR(J)=T(N+J)/T1 

2570 F ( J )-C2/TR(J)+C3*L0G(TR(J))-C4-TR(J)^6 

2580 NEXT 

2590 DF=F(0)-F(1) 

2600 AL=(L0G(P(N)/P(N+1))-C5.DF)/(L0G(T(N)/T(N+1))-C6*DF) 

2610 PC-EXP(LOG(P(N))-C5*F(0)-AL*(LOG(TR(0))-C6*F(0))) 

2620 VC=C7*T1/PC/(C8+C9*AL) 

2640 TR(2j=T(3)/T*i^V(2 j=M*(CC-CD*TR(2)+CE*( (1 -TR(2) )*(1/3) ) )/D 
2650 T2=T1+CF*(V(1)-V(2)) 

2660 IF ABS(T2-T1)<-CG THEN 2680 

2670 T1=T2:G0T0 2550 'loop if not converged 

2680 PB(0)-T1:P8(1)-PC:PB(2)-VC*CN:PB(3)-.2033*AL-1.1816 

2690 RETURN 

2700 REM Estimate bpt by Antoine 
2710 B«LOG(P(1)/P(2))/(1/T(2)-1/T(1)) 

2720 A-LOG(P(1))+B/T(1) 

2730 TD-B/(A-LOG(C)) 

2740 RETURN 
2980 REM 


2990 REM Compound name 

3000 INPUT"Nome of compound";YA 

3010 IF JF THEN 3130 * j f is unit flog 

3020 PRINT:PRINT"Which units ore you using?" 

3030 PRINT:PRINT"1) mmHg ond deg C" 

3040 PRINT"2) mmHg ond deg F" 

3050 PRINT"3) psia and deg F" 

3060 PRINT"4) kPo ond deg C" 

3070 NC-4:GOSUB 6070 

3080 JF-NC:ON JF GOTO 3100.3110.3120 


3090 YP=Y( 

2 ) 

1:YT*Y( 

[9 

IrGOTO 3130 

3100 YP-YI 


) :YT«YI 

<9J 

1 :GOTO 3130 

3110 YP-YI 

10 ; 

!:YT»YI 

;s; 

1:GOTO 3130 

3120 YP-YI 

[11! 

):YT-YI 

is; 



3130 RETURN 


3490 REM Disploy results on screen 

3500 CLS , , „„ , 

3510 YC-"CRITICAL PROPERTIES OF "+YA:J=(NS-LEN(YC))/2 
3520 PRINT TAB(J);YC 
3530 PRINT 

3540 J-(NS-40)/2:K-(NS+30)/2 

3550 PRINT TAB(Jj"Critical temperature, K:";:PRINT TAB(K) USING Y1;PB(0) 

3560 PRINT TAB(J)"Criticol pressure. MPo:";:PRINT TAB(K) USING Y3;PB(1) 

3570 PRINT TAB(J+19)"otmo:"PRINT TAB(K) USING Y1;PB(1)/CK 

3580 PRINT TAB(J)"Critical volume, cc/mol:";:PRINT TAB(K) USING Y1;PB(2) 

3590 PRINT , v 

3600 PRINT TAB(J)"PIt 2 er acentric factor :";:PRINT TAB(K) USING Y2;PB(3) 

3610 PRINT TAB(J)"RIedeI critical parameter :";:PRINT TAB(K) USING Y2;AL 

3620 GOSUB 6030 

3630 RETURN 


3990 REM printer output 
4000 CLS 

4010 J-PEEK(14312) AND 240 'check if printer ready 
4020 IF J-48 THEN 4060 

4030 PRINT"Printer not on line - press <ENTER> when ready" 

4040 Y«INKEY$:IF Y- M " THEN 4040 

4050 GOTO 4000 

4060 IF LP THEN 4370 

4070 PRINT"If you ore going to calculate properties for several 
substances":PRINT"the results can be printed os a table." 

4080 PRINT"Otherwlse they will be printed with each set as a 
separate":PRINT"report." 

4090 PRINT"Press <T> for tabulated results, <S> for seporote reports"; 
4100 YR*"Tt S s":GOSUB 6010 
4110 LP-(KA<3) 

4120 LPRINT TAB(10)"ProJect: ";YB;TAB(70)YD:LPRINT 

4130 IF LP THEN 4270 

4140 REM Single printout 

4150 J«(80-LEN(YC))/2:LPRINT TAB(J);YC 
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USING Y1;PB(0 
USING Y3;PB 




4160 LPRINT 

4170 LPRINT TAB(18)"CrItIcoI temperoture, K:"::LPRINT TAB(55 
4180 LPRINT TA8(18)"Crltlcol pressure, MPa:"j:LPRINT TAB(55 
4190 LPRINT TAB(37)"atma:";:LPRINT TAB(55) USING Y1;PB(1)/.10133 
41M0 LPRINT TAB ^ 18 ^" Crltlcal volum «* cc/moILPRINT TAB(55) USING Y1;PB(2) 

4220 LPRINT TAB(18)"P1tier acentric factor :";:LPRINT TAB(55) USING Y2:PB(3) 
4230 LPRINT TAB(18)"Rledel critical parameter :"j:LPRINT TAB(55) USING 
Y2;AL:GOTO 4240 v ' 

4240 LPRINT:LPRINT TAB(10)"These properties calculated using the method of 
Rummens ond Rajan":LPRINT TA8(10)“wlth the following Input dataLPRINT 
4250 LPRINT TAB(18)"Mo I ecu Iar weight"::LPRINT TAB(55) USING Y3:M 
4260 IF P(0) THEN LPRINT TAB(18) Y(5)+" "+YT;:LPRINT TAB(55) USING Y1;E(2,4) 
4270 LPRINT TAB(18) ZZ(5);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+" 

"+YT;E(1,5),E(2,5) 

4280 IF E(1,6) THEN LPRINT TAB(18) ZZ(6);:LPRINT TAB(45) USING Y2+" "+YP+" 
@"+Y1+" "+YT;E(1,6),E(2,6) 

4290 LPRINT TA8(18)ZZ(8);:LPRINT TAB(45) USING Y2+ 

"+YT;E(1,8),E(2,8) 

4300 LPRINTCHR$(12) 

4310 GOTO 4380 
4320 REM Tabular printout 

4330 LPRINT TAB(10)"Name";TAB(50)"CrItIcoI";TAB(70 
4340 LPRINT TABf40V'Temp"jTAB(50)"Pressure";TAB(62 
. ' K";TAB(49)"MPa atm";TAB(62 


g/cc"+" @"+Y1+“ 


40 


("Acentric" 

)"Vo 1ume":TAB(70)"factor" 
("cc/moI" 


4350 LPRINT TAB 
4360 LPRINT 

4370 LPRINT TAB(10);YA;:LPRINT TAB(40) USING Y1;PB(0);:LPRINT TAB(47) USING 


:LPRINT TAB 
:LPRINT TAB 




Y3;PB(1);: 

Y1;PB(2);: 

4380 RETURN 
4490 REM Menu 
4500 CLS 
4510 PRINT® FN LC(1,NS/2-3)," 
4520 PRINT:PRINT TAB(10) M 1) H 


USING Y1;PB(1 
USING Y2;PB 




10133;:LPRINT TAB(62) USING 



WHAT NEXT" 

Hardcopy of results" 

Save critical properties to disk" 
New project" 

Calculate another material" 

End program" 


4530 PRINT TAB 
4540 PRINT TAB 
4550 PRINT TAB 
4560 PRINT TAB 
4570 NC»5:G0SUB 6070 
4580 RETURN 

4600 REM Project Intro routine 
4610 CLS:LP«0:JF«0:INPUT"Enter project t!tle";YB 
4620 YD«LEFT$(TIME$,8):PRINT"Project date (default 
4630 RETURN 

4990 REM Save critical data 

5000 GOSUB 5240:GOSUB 5120:GOSUB 5170 

5010 CLS:PRINT"Savlng to file ";Y 

5020 IF N>LOF(1)/LF THEN LSET XF$«STRING$(64," ") 

5030 LSETNF$=YH 

5040 LSETMF$«MKS$(M):LSETBF$»MKS$(TB) 


";YD;")";:INPUT YD 


5050 LSETTF$-MKS$(PB(0 
5060 LSETVF$*MKS$(PB 


fflj; 


LSETPF$-MKS$(PB 




10133) 


•I ^FTWFtmlulir^'tf PRr 

5070 LSETDF$»MKS$(SG):LSETSF$-MKS$(T) 

5080 PUT1.N 
5090 CLOSE 1 
5100 RETURN 

5110 REM Open file for crlt data 
5120 Y=LEFT$(YA,1)+"CRIT/DAT" 

5130 OPEN"R",1,Y,128 

5140 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 
AS DF$,4 AS SF$,64 AS XF$ 

5150 RETURN 

5160 REM Find If name In record 
5170 N-1 

5180 IF N>LOF(1)/LF THEN 5220 
5190 GET 1,N 

5200 J=LENfYH):K-LEN(NF$):IF LEFT$(NF$,J)*YH THEN IF RIGHT$(NF$,K- 
J)»STRING$(K-J," ") THEN 5220 
5210 N=N+1:GOTO 5180 
5220 RETURN 


5230 REM Convert name to cops 
5240 YH-YA 

5250 FOR J-1 TO LEN(YA) 

5260 K«ASC(MID$(YA,J)) 

5270 IF K>96 AND K<123 THEN YL-CHR$(K-32):MID$(YH,J)-YL 
5280 NEXT 
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5290 RETURN 

5990 REM Subroutines 

6000 YR«"YyNn" 

6010 Y»INKEY$: IF Y« ,: " THEN 6010 

6020 KA-INSTR(YR.Y):IF KA THEN PRINT " ";Y:RETURN ELSE 6010 
6030 PRINT® FN LC(NR-1, 1),“PRESS ANY KEY TO CONTINUE"; 

6040 Y*INKEY$: IF Y«" M THEN 6040 
6050 CLS 
6060 RETURN 

6070 PRINT:PRINT"Choose by number 
6080 Y*INKEY$:IF Y«"" THEN 6080 
6090 Y%-VAL(Y) 

6100 IF Y%<1 OR Y%>NC THEN 6080 
6110 PRINT Y:NC-YX 
6120 RETURN 
6130 CLS 

6140 IF ERR/2+1*5 OR ERR/2+1-11 OR ERR/2+1-6 THEN 6160 
6150 PRINT"Error In I 1ne";ERL:ON ERROR GOTO 0:RESUME 
6160 PRINT"Math error has occurred in line";ERL 

6170 PRINT"Program will return to data entry to allow you to re-enter your 
input data." 

6180 PRINT"Look for very low or very high, zero or negative values 
of":PRINT"input data." 

6190 PRINT"Check that input data units are correct, and that all values 
arewithin the range of the correlation." 

6200 GOSUB 6030: RESUME 1530 
6490 REM Opening text 
6500 CLS 

6510 PRINT"This program calculates the critical properties and 

acentric":PRINT"factors for many compounds.":PRINT 

6600 PRINT"It is based on the correlation by Rummens and Rajan, 

published":PRINT"In the Can.J.Ch.E., Jun 1979, (Vol 57, No.3), page 349." 

6610 PRINT:PRINT"Input data required are the molecular weight, the vapor" 

6620 PRINT"pressure at any two temperatures, and the density at 

any":PRINT"temperature." 

6630 PRINT:PRINT"One of the vapor pressure points may be the normal 

boiIing":PRINT"point, although the authors recommend against this, 

and":PRINT"suggest two other points 40 to 60 K apart will give best results" 

6640 GOSUB 6030 

6650 RETURN 


I istingl.bas 

"Small-Scale Engineering Applications," by J. Neil 
Stone. July, page 253. 


8540 REM Read data from file 
8550 CLS 

8560 PRINT"Checking disk for data..." 

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720 

8580 IF N>LOF(1)/LF THEN 8650 

8590 A(2,KS)»CVS(MF$):A(2,KS+1)»CVS(TF$) 

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)-CVS(VF$) 

8610 A(2,KS+4)-CVS(WF$):A(2,KS+5)-CVS(DF$) 

8620 A(2,KS+6)-CVS(SF$):A(2,KS+7)-CVS(FF$) 

8630 FOR J«1 TO 7:IF ABS(A(2,KS+J))<C3 THEN A(2,KS+J)»0 
8640 NEXT 
8650 RETURN 

8660 REM Open file for crit data 
8670 Y«LEFT$(YH,1)+"CRIT/DAT" 

8680 OPEN"R",1,Y,128 

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$, 
4 AS VF$,4 AS WF$,4 AS DF$,4 AS SF$,4 AS FF$,60 AS XF$ 
8700 RETURN 

8710 REM Find if name In record 
8720 N-1 
8730 GET 1,N 

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)-YH THEN IF 
RIGHT$(NF$,K-J)«STRING$(K-J," ") THEN 8760 
8750 N-N+1:IF N<«L0F(1)/LF THEN 8730 
8760 RETURN 

8770 REM Convert name to caps 
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8780 VH-VB 

8790 FOR J-1 TO LEN(YB) 

8800 K«ASC(MID$(YB.J)) 

8810 IF K>96 AND K<123 THEN YL-CHR$(K-32):MID$(YH,J)-YL 
8820 NEXT 
8830 RETURN 

8840 REM Write data to disk 

8850 IF N<-LOF(1)/LF THEN LSET FF$-MKS$(A(2,KS+7)): 

GOTO 8920 
8860 LSET NF$-YH 

8870 LSET MF$«MKS$(A(2.KS)):LSET TF$=MKS$(A(2.KS+1)) 
8880 LSET PF$«MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3)) 
8890 LSET WF$-MKS$(A(2,KS+4)):LSET DF$=MKS$(A(2,KS+5)) 
8900 LSET SF$=MKS$(A(2,KS+6)):LSET FF$-MKS$(A(2,KS+7)) 
8910 LSET BF$« M 
8920 PUT 1.N 
8930 CLOSE 1 
8940 RETURN 


list!ng2.bas 

"Small-Scale Engineering Applications," by J. Nell 
Stone. July, page 253. 


200 NS=64:NR»16:LF«1 ’screen parameters 
for TRS80 

210 ’NS»80:NR=24:LF-128 ’screen parameters 
for 80x24 (IBM) 

220 DEF FN LC(J,K)-(J-1)*NS+K-1 


vleclbm.bas 

"Small-Scale Engineering Applications," by J. Neil 
Stone. July, page 253. 


0 REM ESTIMATE VISCOSITY - May 85 - VISCIBM.BAS. Version for BASICA 
10 REM Final, Sept 2nd, 1985 

20 REM Data input screen based on concept of L.E.Sparks, ACCESS 1982, p10 
30 REM Edited for BYTE Dec 85 
40 GOTO 160 


50 DATA"****** VISCOSITIES ******" 

60 DATA"* OF LIQUIDS AND MIXTURES *" 

by" 

J.Neil Stone" 

Ledge Engineering Inc" 

179 Lansdowne Avenue" 

110 DATA" Kingsville, Ontario, N9Y 3J2" 

120 DATA" " 

130 DATA" **** May 1985 **♦*" 

140 CLS:FOR J-1 TO 9:READ Y:LOCATE NR/2-5+J,NS/2-17:PRINT Y:NEXT 

150 RETURN 

160 CLEAR 1500 

170 DEFINT J-L,N:DEFSTR X-Z 

180 DIM 


70 DATA" 
80 DATA" 
90 DATA" 
100 DATA" 


Y,J,K,NS,KP,Y%,LC,KQ,AT,KC,N,UT,A,J9,ET,TR,TL,J8,J$,KS,RD,NL,NC,F2,NR,V,NM 
’simple vars 

210 NS=80:NR-24:LF=128 ’ parameters for 80x24 (IBM) 

220 DEF FN LC(J,K)*(J-1)*NS+K-1 
230 GOSUB 50 'dispI ay ti11e 

240 DIM A(2,92),AX(10),AY(10),YT(8),Y(8),AV(10),AM(10),YN(10),YM(3),MC(10) 
’arrays 

250 REM Set up message strings 

260 Y(1)="MoI ecu I or weight":Y(2)«"Cr11icaI temp, K":Y(3)="CriticaI press, 
atm":Y(4)="Critlea I vol, cc/moI":Y(5)*"Acentric factor":Y(8)="Me11ing point, 
deg C":Y(6)*"Density, g/cc (SG)":Y(7)*"Temp. of density measure, deg C" 

270 YM(1)="PrzezdzieckI & Sridhar":YM(2)-"StieI & Thodos":YM(3)="AIChE Data 
Prediction ManuaI" 

280 Z= "—> " : Z1 =CHR$ (91) +CHR$ (10) +CHR$ (13 ) + "Xx " +CHR$ ( 9 ) : Z3= " " : Z4= " <— 

":Z6»".-0123456789":Z2«Z6+Z1:Z5*Z6+"ED+"+CHR$(13)+CHR$(8) 

290 Z8="USE UP, DOWN, RT ARROWS TO SELECT ENTRY. <X> TO EXIT.":Z9»"USE "+Z4+" 


202 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 









July 


TO CORRECT. PRESS <ENTER> WHEN DONE":ZC-STRING$(17," "):ZS=STRING$(79, 11 ") 

300 Y1-"###.##":Y2-"###":Y3-"##.####":Y4="####.####":Y5-"##.####- 

310 REM Set up constants 

320 C1*273.16:C2-2/7:C3*1E-10 

330 ON ERROR GOTO 7190 

340 GOTO 1000 'to main prog 

390 REM All-purpose screen for 1,2 or 3 col numeric entry 

400 REM Screen layout 

410 CLS:PRINT TAB((NS-LEN(ZA))/2) ZA 

420 PRINT STRING$(NS-1,"»" } 

430 FOR J*1 TO NT:J$-RIGHT$(STR$(J),1) 

440 PRINT YT(J); 

450 IF INSTR(ZD,J$) THEN PRINT-.GOTO 490 ELSE IF INSTR(ZG,J$) THEN 480 
460 IF J8>2 THEN PRINT TAB(NS-45);A(0.KS+J-1); 

470 IF J8>1 THEN PRINT TAB(NS-29);A(1,KS+J-1); 

480 PRINT TAB(NS—13);A(2,KS+J-1) 

490 NEXT 

500 REM Display data as SP to prevent overflows 
510 LOCATE 14,1:PRINT STRING$(NS-1,95) 

520 LOCATE 15,1:PRINT ZS;:LOCATE 15,1:PRINT ZB; 

530 REM Begin display 

540 KQ-NS-17:KP-KL+1:J9=6:G0T0 600 

550 LOCATE KP+1,KQ+1:PRINT Z; 

560 LOCATE 16,1:PRINT ZS;:LOCATE 16,1:PRINT Z8; 

570 Y$*INKEY$: IF Y$* ,,,, THEN 570 

580 IF LEN(Y)«1 THEN IF INSTR(Z2,Y$)-0 THEN 570 

590 IF LEN(Y)»1 THEN J9-INSTR(Z1,Y$) ELSE J9=ASC(RIGHT$(Y,1)):IF J9-80 THEN 

J9-2 ELSE IF J9=72 THEN J9=1 ELSE 570 

600 IF J9=0 THEN 760 ELSE LOCATE KP+1,KQ+1:PRINT Z3; 

610 ON J9 GOTO 640,620,620,630,630,670 
620 J9*1:GOTO 650 
630 RETURN 
640 J9=-1 

650 KP*KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL+1 THEN KP*KM+1 

660 GOTO 710 

670 ON J8 GOTO 710,700 

680 IF KQ-NS-49 OR KQ*NS-33 THEN KQ*KQ+16 ELSE KQ*NS-49 
690 GOTO 710 

700 IF KQ-NS-33 THEN KQ-NS-17 ELSE KQ*NS-33 
710 ZF*STR$(KP-1):ZF*RIGHT$(ZF,LEN(ZF)-1)+"," 

720 IF INSTR(ZD.ZF) THEN IF J9*6 THEN J9-1:GOTO 650 ELSE 650 
730 IF INSTR(ZG.ZF) THEN KQ-NS-17 
740 GOTO 550 

750 REM Data entry section 

760 LOCATE 16,1:PRINT ZS;:LOCATE 16,1:PRINT Z9; 

770 KC-1:ZE*Y$ 

780 LOCATE KP+1,KQ+1:PRINT ZC;:LOCATE KP+1,KQ+5:PRINT ZE;CHR$(95); 

790 Y$»INKEY$: IF Y$- ,,M THEN 790 

800 Y%*INSTR(Z5,Y$):IF Y%«0 THEN IF LEN(Y$)>1 AND ASC(RIGHT$(Y$,1))«75 THEN 
860 ELSE 790 

810 IF Y%>15 THEN ON Y%-15 GOTO 880,860 
820 KC-KC+1 
830 ZE*ZE+Y$ 

840 LOCATE KP+1,KQ+KC+4:PRINT Y$;CHR$(95); 

850 GOTO 790 

860 KC-KC-1:IF KC<-0 THEN KC-0:ZE- M " ELSE ZE-LEFT$(ZE,KC) 

870 GOTO 780 

880 KE*(KQ-NS+49)/16 

890 A(KE,KP+KS-2)-VAL(ZE) 

900 LOCATE KP+1,KQ+1:PRINT ZC;:LOCATE KP+1,KQ+4:PRINT CSNG(VAL(ZE)); 

910 ZE-"":J9-1 

920 IF KQ-NS-17 THEN KP-KP+1 
930 IF KP>KM+1 THEN KP-KL+1 
940 GOTO 670 
990 REM Main program 

1000 GOSUB 8000 'introductory text 

1010 GOSUB 6620 'title etc 

1020 GOSUB 6080 'main menu 

1030 ON NM GOSUB 1250,1250,1500 'goto correct routine 

1040 IF NC<>6 THEN 1060 

1050 ON ERROR GOTO 0:END 'end of program 

1060 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)-0:NEXTJ,K:LP-0 

1070 IF NC-5 THEN JP-0:LT-0 

1080 ON NC-3 GOTO 1020,1010 

1240 REM Viscosity prediction by both methods 
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1250 IF NE THEN 1290 
1260 GOSUB 8270 
1270 GOSUB 2000 
1280 GOSUB 8550 
1290 GOSUB 2030 
1300 GOSUB 2150 
1310 GOSUB 6170 


•go to Input If returned by error 
• intro text 
•name of substance 
•load data from file, if any 
•enter phys props 
•calc for substance 
'calculation options 
1320 IF TN-0 THEN GOSUB 2360:GOSUB 4500 ELSE GOSUB 2500 
•calc for temp of Interest 
1330 GOSUB 6400 *what next 

1340 ON NC GOTO 1360,1310,1370 
1350 RETURN 

1360 CLS:GOSUB 5000:GOTO 1330 

1370 FOR K-0 TO 2:FOR J-1 TO 8:A(K,J)»0:NEXT J ,K: LP-0-.GOTO 1270 
1490 REM Mixture routine 

1500 IF NE THEN 1540 'to entry if return on error 
1510 GOSUB 8470 •Intro blurb 

1520 GOSUB 3000 ’get names of materials 

1530 IF NL-2 THEN GOSUB 3120 ’range of calcs? 

1540 GOSUB 3250 'data in 

1550 GOSUB 3490 •estimate missing viscosities 

1560 GOSUB 3750 ’viscosity of mixture/print 

1570 GOSUB 6510 'what next? 

1580 ON NC GOTO 1610,1530,1650 
1590 RETURN 


1600 REM Hardcopy results 

1610 IF AL THEN CLS:PRINT M Too latel Cannot print results for range now.":GOSUB 
7070:GOTO 1570 

1620 CLS:GOSUB 5410 ’hardcopy results 

1630 GOTO 1570 

1640 REM Clean out data 

1650 AL-0:FOR J-1 TO NL:FOR K-0 TO 2:A(K,J)«0:NEXT K.JrGOTO 1520 
1990 REM Input material data 
2000 CLS:KS«1 

2010 INPUT"Name of Substance";YB 
2020 RETURN 

2030 CLS:NE-0 ’reset error flag 

2040 KS-1:KL»1:KM-8:ZA-"PR0PERTIES OF "+YB 

2050 ZB-" M :ZD-" M :ZG-"":J8-1 

2060 IF NM-2 THEN KM-7 ’no f. pt needed for St k Th 

2070 FOR J-1 TO KM:YT(J)-Y(J):NEXT ’Instal titles 

2080 NT-9-NM 'no of titles 

2090 GOSUB 410 'to data input 

2100 GOSUB 2600 ’check Input data valid 

2110 IF NE THEN NE»0:GOTO 2090 ELSE GOSUB 8850 

2120 

MW=A(2,1):TC-A(2,2):PC-A(2,3):VC=A(2,4):W*A(2,5):TF-A(2,8)+C1:SG=A(2,6):TD=A(2 
,7)+C1 ’get data in equation variables 
2130 RETURN 

2140 REM Calculate basic parameters 
2150 CLS 

2160 TR-TD/TC:FZ«.29056-.08775*W ’Yamada k Gunn, 1973 
2170 GOSUB 2290 

2180 VS-MW/SG/F2 ’calc scaling factor 

2190 IF NM-2 THEN GOTO 2320 ’Stiel and Thodos 

2200 REM Pr and Sr method 

2210 TR-TF/TC 

2220 GOSUB 2290 

2230 VM—F2*VS 

2240 VZ-.0085*TC*W-2.02+VM/(.342*TR+.894) 

2250 F1=4.27+.032*MW-.077*PC+.014*TF-3.82*TR 

2260 B-.33+VC/F1 - 1.12 

2270 RETURN 

2280 REM Calc f2(t) 

2290 F2-FZ*((1-TR)~C2) •Yamada & Gunn 1973 
2300 RETURN 

2310 REM Stiel and Thodos parameter 
2320 ES«TC~(1/6) 

2330 ES-ES/SQR(MW)/(PC~(2/3)) 

2340 RETURN 

2350 REM Calc for specific temp 
2360 TR-(TL+C1)/TC 
2370 GOSUB 2290:V=F2*VS 

2380 IF NM-2 THEN GOTO 2420 *to Stiel and Thodos 
2390 ET-B*(V/VZ-1):ET-1/ET 
2400 GOTO 2480 
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2410 REM StleI and Thodos calc 

2420 IF TR<1.5 THEN UB=34E-05*(TR~.94) ELSE UB»17.78E-05*((4.58*TR- 
1.67)*(5/8)) 'calc low press vise 
2430 RD-VC/V 

2440 UT«(((.0093324*RD-.040758)*RD+.058533)*RD+.023364)*RD+.1023 

2450 UT-UT*UT*UT*UT 

2460 UT-UT-1E-04+UB 

2470 ET-UT/ES 

2480 RETURN 

2490 REM Calc for range of temps 
2500 CLS 

2510 FOR TL-TS TO TE STEP TN 
2520 GOSUB 2360 
2530 GOSUB 5170 
2540 GOSUB 4650 
2550 NEXT 

2560 TL-TL-TN ’restore last temp calc’d 

2570 IF N THEN GOSUB 7070 
2580 RETURN 

2590 REM Check validity of input data 
2600 FOR J-KS TO KS+5 
2610 IF A(2,J)>0 THEN 2630 

2620 CLS:PRINT Y(J-KS+1);" cannot be zero or negative.":NE=1 
2630 NEXT 

2640 IF NE THEN PRINT:PRINT"Program will return to data entry. Please correct 
input. M :GOSUB 7070 
2650 RETURN 

2990 REM Initial input for mixtures 
3000 CLS:JP-0 

3010 NL-0 • intialise - NL no of comps 

3020 NL-NL+1:YN(NL)-" M :MC(NL)-0:PRINT "Name of component no:";NL just 
<ENTER> if no more componentsINPUT YN(NL) 

3030 IF YN(NL)o"" THEN IF NL<10 GOTO 3020 

3040 NL-NL-1:IF NL<2 THEN PRINT "Must have at least two components:GOTO 3020 
3050 CLS 

3060 PRINT "Are your compositions in wt% or mol% - type <W> or <M>" 

3070 YR-"WwMm":GOSUB 7040 

3080 MX»(KA>2) ’mx true if mol% 

3090 IF MX THEN YU-"molX" ELSE YU-"wtX" 

3100 RETURN 

3110 REM Calculate for range 

3120 CLS:AL-0:MP-0:PRINT "Do you want to automatically calculate viscosities 
for a rangeof compositions Y/N?" 

3130 GOSUB 7030 
3140 IF KA>2 THEN 3230 

3150 PRINT "Minimum value of ";YU" for ";YN(1);:INPUT AL 

3160 IF (AL<0) OR (AL>100) THEN PRINT YU;"must be in range 0-100":GOTO 3150 
3170 PRINT "Maximum value of ";YU" for ";YN(1);;INPUT AH 

3180 IF (AH<0) OR (AH>100) OR (AH<AL) THEN PRINT YU;"must be in range 0-100 

and max must be bigger than min.":GOTO 3170 

3190 PRINT "Increments of ";YU" for ";YN(1);:INPUT AD 

3200 PRINTrPRINT "Do you want hardcopy of the results as they are done, Y/N?" 
3210 GOSUB 7030 

3220 MP«(KA<3) ’true if hardcopy needed 
3230 RETURN 

3240 REM Initial data entry for mixtures 

3250 FOR J-1 TO NL:IF LEN(YN(J))>NS-51 THEN YT(J+1)»LEFT$(YN(J),NS-51) ELSE 
YT(J+1)»YN(J) 

3260 NEXT 

3270 YT(1)-STRING$(NS-46," ")+"Visc - cp"+STRING$(7," ")+"MoI.Wt"+STRING$(10," 
")+YU 

3280 ZA-"MIXTURE VISCOSITY INPUT DATA" 

3290 ZB-"LEAVE ANY UNKNOWN DATA AS 0 - MW NOT NEEDED IF USING MOL%" 

3300 ZD-"1,":ZG-"":J8-3:NT-NL+1:KL-2:KM-NL+1:KS-0 
3310 IF AL THEN A(2,1)-AL:A(2,2)»100-AL 
3320 GOSUB 410 ’screen routine 

3330 GOSUB 3390 ’check data 

3340 IF NE THEN NE«0:GOTO 3320 ’return if data check not OK 

3350 FOR J-1 TO NL:AV(J)-A(0,J):AM(J)-A(1,J):AX(J)«A(2,J):NEXT ’put data into 

working vars; av-vI sc,am-mw,ax-frn 

3360 TL—1000 ’flag to show temp not set 

3370 RETURN 

3380 REM Check screen Input for mixtures 
3390 CLS:NE-0:A-0 
3400 FOR J-1 TO NL 
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3410 IF NOT MX THEN IF A(1,J)<-0 THEN PRINT"MoI ecu Iar wt for M ;YN(J); M 
requI red":NE-1 

3420 IF NL<>2 OR AL-0 THEN IF A(2,J)<0 OR A(2,J)>100 THEN PRINT YU;" of 
";YN(J); M out of range":NE«1 
3430 A-A+A(2,J) 

3440 NEXT 

3450 IF A>100 OR A<100 THEN PRINT M Componente do not add to 100 M ;YU:NE«1 
3460 IF NE THEN GOSUB 7070 
3470 RETURN 

3480 REM Estimate viscosity of missing Items 

3490 CLS:NK«0 'nk Is temperature flag 

3500 FOR LM-1 TO NL ’lm is main counter 

3510 IF AV(LM) THEN 3720 ’skip If vise given 

3520 MC(LM)«1:PRINT "Estimating viscosity of ";YN(LM) 

3530 PRINT:PRINT "Is ";YN(LM):PRINT "a non-associating compound, Y/N?"; 

3540 GOSUB 7030 

3550 IF KA<3 THEN NM-1 ELSE NM-2 

3560 YB-YN(LM):KS-LM*8+4:A(2,KS)-AM(LM):GOSUB 8550 ’check for data on disk 
3570 CLS:NE-0 ’reset error flag 
3580 KL-1:KM-8:ZA-"PROPERTIES OF "+YB 
3590 ZB-"":ZD-"":ZG-"":J8-1 

3600 IF NM-2 THEN KM-7 ’no f. pt needed for St k Th 

3610 FOR J-1 TO KM:YT(J)»Y(J):NEXT ’Instal titles 

3620 NT-9-NM ’no of titles 

3630 GOSUB 410 ’to data Input 

3640 GOSUB 2600 'check Input data valid 

3650 IF NE THEN NE-0:GOTO 3630 ELSE GOSUB 8850 

3660 

MW»A(2,KS):TC«A(2.KS+1):PC-A(2.KS+2):VC-A(2.KS+3):W»A(2,KS+4):TF«A(2.KS+7)+C1: 
SG-A(2,KS+5):TD*A(2,KS+6)+C1 ’get data In equation variables 
3670 GOSUB 2150 'start calculation 

3680 CLS:IF NK-0 THEN NK«1:INPUT "Temperature of estimate, deg C.";TL 
3690 GOSUB 2360 

3700 AV(LM)-ET:A(0,LM)-CSNG(ET) 'save answer 

3710 CLS:PRINT "Viscosity of ";YN(LM);" caIcuIated":G0SUB 7010:NM-3 

3720 NEXT 

3730 RETURN 

3740 REM Calculate vise of mixture 
3750 IF AL THEN GOTO 3790 

3760 IF NOT MX THEN GOSUB 3890 ’conv to moles If nec 

3770 GOSUB 3960 ’calculate mixture vise 

3780 GOTO 3860 ’to return 

3790 N=0:FOR A-AL TO AH STEP AD 

3800 AX(1)»A:AX(2)-100-A 

3810 IF NOT MX THEN GOSUB 3890 

3820 GOSUB 3960 

3830 IF MP THEN GOSUB 5570 

3840 GOSUB 4730 

3850 NEXT 

3860 IF NL>2 OR AL-0 THEN GOSUB 4550 ELSE IF N THEN GOSUB 7070 ’to screen if 
results requ’d 
3870 RETURN 

3880 REM Convert to mole frn 

3890 AT«0:FOR J-1 TO NL 

3900 AY(J)-AX(J)/AM(J):AT-AT+AY(J) 

3910 NEXT 

3920 FOR J-1 TO NL 
3930 AX(J)-AY(J)*100/AT 
3940 NEXT:RETURN 
3950 REM Vise of mixture 
3960 AT-0 

3970 FOR J-1 TO NL 

3980 AT-AT+AX(J)*LOG(AV(J)) 

3990 NEXT 

4000 ET»EXP(AT/100) ’viscosity of mixture 
4010 RETURN 

4490 REM Print results 
4500 CLS 

4510 PRINT "Viscosity of ";YB;" at";:PRINT USING " ###.# deg C Is ###.### 
cp";TL,ET 
4520 PRINT 
4530 RETURN 

4540 REM Screen print for mixture 
4550 CLS 

4560 PRINT "Viscosity of mixture of:" 

4570 FOR J-1 TO NL 
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4580 PRINT TAB(5) USING Y1;A(2,J);:PRINT" ";YU;" M ;YN(J) 

4590 NEXT 

4600 PRINTrIF TLo-1000 THEN PRINT "ot " j TL;" deg C"; 

4610 PRINT " is";:PRINT USING Y3;ET;:PRINT " cp" 

4620 GOSUB 7070 
4630 RETURN 

4640 REM Screen print list of results 
4650 IF TLoTS AND N<>0 THEN 4680 
4660 N-0:PRINT “Viscosity of ";YB 

4670 PRINT TAB(5) "Temperature, deg C";TAB(NS-25)"Viscosity, cp" 

4680 PRINT TAB(12) USING Y2;TL;:PRINT TAB(NS-23) USING Y4;ET 
4690 N-N+1 

4700 IF N-NR-4 THEN GOSUB 7070:N=0:CLS 
4710 RETURN 

4720 REM Screen display list of mixture results 

4730 IF AoAL AND N<>0 THEN 4760 'jump titles if not first time 
4740 CLS:N-0:PRINT TAB(12);YU;" of";TAB(54)"Viscosity" 

4750 PRINT YN(1);TAB(25) YN(2);TAB(58)"cp" 

4760 PRINT USING Y1;A; 

4770 PRINT TAB(25) USING Y1;100-A; 

4780 PRINT TAB(56) USING Y3;ET 
4790 N-N+1 

4800 IF N-NR-4 THEN GOSUB 7070:N-0 
4810 RETURN 

4990 REM Hardcopy results 

5000 IF TN THEN CLS:PRINT "Too late! Cannot print results for range 

now.":GOSUB 7070:GOTO 5150 

5005 GOSUB 6000 

5010 CLS:0N JP GOTO 5020,5090 

5020 GOSUB 5290:GOSUB 5330 

5030 LPRINT 

5040 LPRINT TAB(5) "viscosity of ";YB;" estimated by method of ";YM(NM);" is:" 

5050 LPRINT:LPRINT TAB(25) USING Y4+" cp at "+Y2+" deg C";ET,TL 

5060 LPRINT:LPRINT 

5070 GOTO 5150 

5080 REM Table heading 

5090 IF LT THEN 5140 'LT is flag for table 
5100 GOSUB 5290 
5110 LPRINT 

TAB(5)"Substance";TAB(25)"Temperature";TAB(40)"Viscosity";TAB(52)"Method" 

5120 LPRINT TAB(30)"deg C";TAB(44)"cp" 

5130 LPRINT:LT-1 

5140 LPRINT TAB(5)YB;:LPRINT TAB(29) USING Y2;TL;:LPRINT TAB(40) USING 
Y4;ET;:LPRINT TAB(52) YM(NM) 

5150 RETURN 

5160 REM List results for temp range on printer 
5170 IF LP-0 THEN 5270 
5180 IF TLOTS THEN 5250 
5190 GOSUB 5290:GOSUB 5330 

5200 LPRINT TAB(5)"Estimated viscosities using method of ";YM(NM) 

5210 LPRINT 

5220 LPRINT TAB(10)"Temperature";TAB(45)"Viscosity" 

5230 LPRINT TAB(13)"deg C";TAB(49)"cp" 

5240 LPRINT 

5250 LPRINT TAB(14) USING Y2;TL;:LPRINT TAB(45) USING Y4;ET 
5260 IF TL+TN>TE THEN LPRINT 
5270 RETURN 

5280 REM Print heading 

5290 LPRINT TAB(5)"Project: ";YP;TAB(55)YD 
5300 LPRINT 
5310 RETURN 

5320 REM Input data print 

5330 LPRINT TAB(5)"INPUT DATA for ";YB 

5340 LPRINT 

5350 FOR J-1 TO 9-NM 

5360 LPRINT TAB(10) Y(J);:LPRINT TAB(45) USING Y4;A(2,J) 

5370 NEXT 
5380 LPRINT 
5390 RETURN 

5400 REM Hardcopy for mixtures 
5410 GOSUB 5290 

5420 LPRINT TAB(40)"INPUT DATA":LPRINT 

5430 LPRINT TAB(5)"Substance";TAB(35)"Visc - cp";TAB(48)"Mo I. wt";TAB(63)YU 

5440 FOR J-1 TO NL 

5450 LPRINT TAB(5) YN(J); 
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5460 LPRINT TAB(35) USING Y3;AV(J); 

5470 IF MC(J) THEN LPRINT"*"; 

5480 LPRINT TAB(48) USING Y1;AM(J); 

5490 LPRINT TAB(61) USING Y1;A(2,J) 

5500 NEXT 

5510 LPRINT:LPRINT TAB(10) "* means estimated value, not Input" 

5520 LPRINT:LPRINT TAB(5) "Viscosity of mixture"; 

5530 IF TLo-1000 THEN LPRINT" at";TL;" deg C"; 

5540 LPRINT" is";:LPRINT USING Y3;ET;:LPRINT" cp.":LPRINT 
5550 RETURN 

5560 REM Table of mixture viscosities 

5570 IF AoAL THEN 5700 'only print title first time 

5580 GOSUB 5290 

5590 LPRINT:LPRINT TAB(5) "Viscosities of mixtures of:" 

5600 LPRINT:FOR J-1 TO 2 
5610 LPRINT TAB(10);YN(J) 

5620 NEXT 
5630 LPRINT 

5640 IF TLo-1000 THEN LPRINT TAB(5)" at";TL;" deg C "; 

5650 LPRINT TAB(5) "are as follows:" 

5660 LPRINT:LPRINT TAB(17);YU;" of "; 

5670 LPRINT TAB(55)"VIscosIty" 

5680 LPRINT TAB(5);YN(1);TAB(30);YN(2);TAB(58)"cp" 

5690 LPRINT 

5700 LPRINT TAB(5) USING Y1;A;:LPRINT TAB(30) USING Y1;100-A; 

5710 LPRINT TAB(55) USING Y3;ET 
5720 IF A+AD>AH THEN LPRINT 
5730 RETURN 

5990 REM Hardcopy option menu 

6000 CLS:IF JP=2 THEN 6060 

6010 LOCATE 1,(NS-7)/2:PRINT "PRINT OPTIONS" 

6020 PRINT:PRINT TAB(5)"1) Print Just the current result complete with Input 
data" 

6030 PRINT TAB(5)"2) Print table headings and start table for all":PRINT 
TAB(8)"resuIts until new project is started." 

6040 NC-2:GOSUB 7120 

6050 JP-NC 'JP * flag for choice 

6060 RETURN 

6070 REM Main menu 

6080 CLS 

6090 LOCATE 1,(NS-4)/2:PRINT "MAIN MENU" 

6100 PRINT:PRINT TAB(5)"1) Viscosity of non-associating liquid - most 
accurate" 

6110 PRINT TAB(5)"2) Viscosity of associating liquid - not very accurate" 
6120 PRINT TAB(5)"3) Viscosity of liquid mixture" 

6130 NC=3:GOSUB 7120 
6140 NM=NC 
6150 RETURN 

6160 REM Calculation options 
6170 CLS 

6180 LOCATE 1,(NS-10)/2:PRINT "CALCULATION OPTIONS" 

6190 PRINT:PRINT TAB(5)"1) Estimate viscosity for one specific temperature" 
6200 PRINT TAB(5)"2) Estimate viscosity for a range of temperatures" 

6210 PRINT 

6220 NC*2:GOSUB 7120 
6230 TN=0 

6240 ON NC GOTO 6370 

6250 CLS:INPUT"Start of temperature range, deg C";TS 
6260 INPUT"End of temperature range, deg C";TE 
6270 INPUT"Temperature interval in range, deg C";TN 
6280 PRINT:PRINT "Everything correct, Y/N? "; 

6290 GOSUB 7030 
6300 IF KA>2 THEN 6250 

6310 CLS:PRINT "Do you want results tabulated on printer, Y/N? " 

6320 GOSUB 7030 
6330 LP*(KA<3) 

6340 IF LP THEN PRINT "Press <ENTER> when printer is ready" ELSE 6380 
6350 Y*INKEY$:IF Y*"" THEN 6350 
6360 GOTO 6380 

6370 CLS:INPUT"Temperature, deg C";TL 
6380 RETURN 

6390 REM Menu after calc 

6400 PRINT TAB((NS-4)/2),"WHAT NEXT" 

6410 PRINT 

6420 PRINT TABf5V'1J Hardcopy of result (one result only)." 

6430 PRINT TAB(5r'2) Viscosity for same material at another temperature." 
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6440 PRINT TAB(5)"3) Viscosity for different substance of the same type." 

6450 PRINT TAB(5)"4) Main menu." 

6460 PRINT TAB(5)"5) New project (all data lost)." 

6470 PRINT TAB(5)"6) End program." 

6480 NC=6:GOSUB 7120 
6490 RETURN 

6500 REM Menu after mix 

6510 PRINT TAB((NS-4)/2),"WHAT NEXT" 

6520 PRINT 

6530 PRINT TAB(5)"1) Hardcopy of results" 

6540 PRINT TAB(5)"2) Another calculation for same materials." 

6550 PRINT TAB(5)"3) Calculate for a different mixture." 

6560 PRINT TAB(5)"4) Main menu." 

6570 PRINT TAB(5)"5) New project (all data lost)." 

6580 PRINT TAB(5)"6) End program." 

6590 NC«6:GOSUB 7120 
6600 RETURN 

6610 REM Project intro routine 

6620 CLS:INPUT"Enter project title";YP 

6630 YD-LEFT$(DATE$,10):PRINT "Project date (default = ";YD;")";:INPUT YD 

6640 RETURN 

6990 REM Subroutines 

7000 REM Delay 

7010 FOR J-1 TO 2000:NEXT:RETURN 
7020 REM Check inkey 
7030 YR»"YyNn" 

7040 Y*INKEY$:IF Y-"" THEN 7040 

7050 KA«INSTR(YR,Y):IF KA THEN RETURN ELSE 7040 

7060 REM Press key to cont 

7070 LOCATE NR,1:PRINT "PRESS ANY KEY TO CONTINUE"; 

7080 Y«INKEY$:IF Y«"" THEN 7080 
7090 CLS 
7100 RETURN 

7110 REM Select from menu 

7120 PRINT:PRINT"Choose by number" 

7130 Y«INKEY$:IF Y-"" THEN 7130 
7140 Y%«VAL(Y) 

7150 IF Y%<1 OR Y%>NC THEN 7130 
7160 PRINT Y:NC-Y% 

7170 RETURN 

7180 REM Error trap 

7190 CLS 

7200 IF ERR-5 THEN 7250 
7210 IF ERR-11 THEN 7290 
7220 IF ERR*54 THEN 7360 
7230 IF ERR*6 THEN 7270 

7240 PRINT "Error in Iine";ERL:0N ERROR GOTO 0:RESUME 

7250 PRINT "Illegal function call error has occurred In Iine";ERL:GOSUB 7340 
7260 PRINT "Look for negative or zero values of input data":GOTO 7310 
7270 PRINT "Overflow error has occurred in Iine";ERL:GOSUB 7340 
7280 PRINT "Look for very low or very high values of input data":GOTO 7310 
7290 PRINT "Division by zero error has occurred in Iine";ERL:GOSUB 7340 
7300 PRINT "Look for very low or zero values of input data" 

7310 PRINT "Check that input data units are correct, and that all values 
arewithin the range of the correlation" 

7320 GOSUB 7070:NE-1 'ne is error flag 
7330 RESUME 1030 

7340 PRINT "Program will return to data entry to allow you to checkvaIidity of 
your input data" 

7350 RETURN 

7360 PRINT "No such file" 

7370 GOSUB 7070:CLOSE:JF=1:RESUME NEXT 
7990 REM Introductory blurb 
8000 CLS 

8010 GOSUB 8220:IF NB THEN 8200 

8020 CLS:PRINT "This program estimates viscosities of pure liquids and 
mixtures" 

8030 PRINT:PRINT "The viscosities of pure, non-associating, liquids are 
estimated by the";CHR$(13);"method of J.W.Przezdzleeki and T.Sridhar published 
in the AIChEJ," 

8035 PRINT "Feb. 1985, p333. It Is the most accurate method and should be 
used";CHR$(13);"If possible." 

8040 PRINT:PRINT "Data required for the estimate are the molecular weight, the 
critical";CHR$(13);"properties, the acentric factor, and at least one value of 
density at a";CHR$(13);"known temperature." 
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8050 PRINTrPRINT "This method gives estimates with an average error of 9%, and 
a maximum error of 40%, but results are very unreliable If used for 
associating IIqulds." 

8060 PRINT:G0SUB 7070 
8070 CLS 

8080 PRINT'Tor associating liquids there Is really no reliable predictive 
method." 

8090 PRINT:PRINT "The method used In this program is that of Stiel and Thodos, 
as descrI bed";CHR$(13);"In *The Properties of Gases and Liquids* by Reid and 
Sherwood, 2nd Ed., p437." 

8100 PRINT:PRINT "Data required for the estimate are the molecular weight, the 
critical M ;CHR$(13);"propertIes, the acentric factor, and at least one value of 
density at a";CHR$(13);"known temperature." 

8110 PRINTrPRINT "This method gives quite large errors (as much as -80%), 
usually on the Iow";CHR$(13);"sIde, for some associating liquids, but no other 
method is any more accurate." 

8120 PRINTrGOSUB 7070 
8130 CLS 

8140 PRINT "Prediction of viscosities for liquid mixtures from pure component 
data !s";CHR$(13);"also rather unreliable." 

8150 PRINTrPRINT "The method used In this program is procedure 8H from the 
AIChE *Data";CHR$(13);"Predict Ion Manual*. It is appropriate for systems 
where the mixtures have";CHR$(13);"viscosities Intermediate between those of 
the components." 

8160 PRINTrPRINT "Data required for the estimate are either the viscosities of 
the components, or the data listed previously to allow them to be estimated. 
Liquid"; 

8170 PRINT "compositions may be entered In mol% or wt%, but in the latter case 
the";CHR$(13);"mo I ecu Iar weight Is also required." 

8180 PRINTrPRINT "This method is not suitable for systems that have maxima or 
minima in the";CHR$(13);"mixture properties." 

8190 GOSUB 7070 
8200 RETURN 

8210 REM Routine to bypass blurbs 

8220 PRINT "This program includes explanatory text and 

instruct Ions.";CHR$(13);"If you are familiar with the program, you can bypass 
these.";CHR$(13);"Do you want instructions displayed for this run, Y/N?" 

8230 GOSUB 7030 

8240 NB-(KA>2) *nb is flag Indicating No Blurbs 
8250 RETURN 

8260 REM Blurb for P&S method 
8270 CLSrIF NB THEN 8450 
8280 IF NM-2 THEN GOTO 8370 

8290 PRINT "This calculation method gives quite accurate results for most" 

8300 PRINT "non-associating compounds. Any errors tend to be on the low" 

8310 PRINT "side, and the errors are more pronounced at lower temperatures," 
8320 PRINT "reaching a maximum close to the freezing point." 

8330 PRINT:PRINT "The only common organics that cannot be handled are 
a I coho Is," 

8340 PRINT "both aliphatic and aromatic. Cyclic and branched compounds 
":PRINT"tend to give quite large errors, usually on the low side." 

8350 PRINT "Organic acids seem to be predictable." 

8360 GOTO 8440 
8370 CLS 

8380 PRINT "This calculation method gives reasonable results for many" 

8390 PRINT "compounds. It works best at temperatures from" 

8400 PRINT "the boiling point up, and the errors are more pronounced":PRINT 
"at lower temperatures." 

8410 PRINT "Only use this method for associating compounds." 

8420 PRINTrPRINT "For all other substances, the Przezdziecki and Srldhar" 

8430 PRINT "method is better." 

8440 GOSUB 7070 
8450 RETURN 

8460 REM Blurb for mixtures 
8470 IF NB THEN 8530 
8480 CLS 

8490 PRINT "This section calculates the viscosity of liquid mixtures from 
the";CHR$(13);"viscosities of the pure components, for up to 10 components." 
8500 PRINTrPRINT "If the pure component viscosities are not known, they will 
be estimated by";CHR$(13);"one of the methods available. Leaving the 
viscosity value as zero during" 

8505 PRINT"data entry will automatically activate the estimating procedure." 
8510 PRINTrPRINT "If there are only two components, a range of mixtures can be 
calculated";CHR$(13);"automatically - you will be prompted for the range if 
this option is chosen." 

8520 GOSUB 7070 
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8530 RETURN 

8540 REM Read data from file 
8550 CLS 

8560 PRINT"Checking disk for data..." 

8570 GOSUB 8780:GOSUB 8670:GOSUB 8720 

8580 IF N>LOF(1)/LF THEN 8650 

8590 A(2,KS)-CVS(MF$):A(2.KS+1)«CVS(TF$) 

8600 A(2,KS+2)-CVS(PF$):A(2,KS+3)=CVS(VF$) 

8610 A(2.KS+4)«CVS(WF$):A(2.KS+5)=CVS(DF$) 

8620 A(2,KS+6)«CVS(SF$):A(2.KS+7)»CVS(FF$) 

8630 FOR J-1 TO 7:IF ABS(A(2.KS+J))<C3 THEN A(2,KS+J)=0 
8640 NEXT 
8650 RETURN 

8660 REM Open file for crit data 
8670 Y*LEFT$(YH,1)+"CRIT.DAT" 

8680 OPEN"R",1,Y,128 

8690 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 
AS DF$,4 AS SF$,4 AS FF$,60 AS XF$ 

8700 RETURN 

8710 REM Find If name In record 
8720 N-1 
8730 GET 1,N 

8740 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K- 

J)«STRING$(K-J," M ) THEN 8760 

8750 N-N+1: IF N<-LOF(1)/LF THEN 8730 

8760 RETURN 

8770 REM Convert name to caps 
8780 YH-YB 

8790 FOR J-1 TO LEN(YB) 

8800 K-ASC(MID$(YB,J)) 

8810 IF K>96 AND K<123 THEN YL=CHR$(K-32):MID$(YH,J)-YL 
8820 NEXT 
8830 RETURN 

8840 REM Write data to disk 

8850 IF N<«LOF(1)/LF THEN LSET FF$«MKS$(A(2,KS+7)):GOTO 8920 
8860 LSET NF$«YH 

8870 LSET MF$*MKS$(A(2,KS)):LSET TF$-MKS$(A(2.KS+1)) 

8880 LSET PF$=MKS$(A(2,KS+2)):LSET VF$=MKS$(A(2,KS+3)) 

8890 LSET WF$-MKS$(A(2»KS+4)):LSET DF$-MKS$(A(2,KS+5)) 

8900 LSET SF$»MKS$(A(2,KS+6)):LSET FF$=MKS$(A(2,KS+7)) 

8910 LSET BF$«" 

8920 PUT 1,N 
8930 CLOSE 1 
8940 RETURN 


crItibm.bas 

"Small-Scale Engineering Applications," by J. Nell 
Stone. July, page 253. 


0 REM Predict critical properties - Apr 85 - CRITIBM.BAS. Version for BASICA 

10 REM Rummens k Rajan, Can.J.Ch.E., Jun 1979, 349 

20 REM Data Input screen concept by L.E.Sparks, ACCESS, 1982 p 10. 

30 REM Edited for BYTE Dec 1985 
40 GOTO 170 


*****" 

**" 


CRITICAL PROPERTY 
PREDICTION 
by" 

J.Neil Stone" 

Ledge Engineering Inc" 

179 Lansdowne Avenue" 
Kingsville, Ontario, N9Y 3J2" 


50 DATA"***** 

60 DATA"** 

70 DATA" 

80 DATA" 

90 DATA" 

100 DATA" 

110 DATA" 

120 DATA" 

130 DATA" **** Apr 1985 ***♦" 

140 CLS:FOR J-1 TO 9:READ Y:LOCATE NR/2-5+J,NS/2-17:PRINT Y:NEXT 
150 GOSUB 6250:RETURN 
160 REM Initialize 
170 CLEAR 500 

180 DEFINT J-L,N:DEFSTR R,X-Z 

190 DIM Y,K,J,M,TD,Y%,LF,KA 

200 ’POKE 16409,1 ’Set caps mode 

210 ’NS-64:NR-16:LF«1 ’parameters for TRS80 

220 NS-80:NR-24:LF-128 ’parameters for 80x24 


(continued) 
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230 DEF FN LC(J ,K)-(J-1)*NS+K-1 

3 S^“).S(2 , .l!)!Y(?2).P(2).Tll(a).F(1).V(2) *orroy. 

260 REM Set up messog© *trlngs . , Y(5)+ . d c «:Y(3)-"Specific 

CORRECT. PRESS <ENTER> WHEN DONE":ZA-STRING$(17, ) 

=32:CK-.10135:CL-760:CM-14.696:CN«1000:CP-273.16 

330 ON ERROR GOTO 6130 
340 GOTO 1500 * to main program 

490 REM Screen routine - put titles In ££U 
500 CLS:LOCATE 1.(NS-LEN(RA))/2):PRINT RA 
510 PRINT STRING$(NS-1."-") 

520 FOR J=KL TO KM 

US IS SIl^N^KSc!) ZZ(J> TAB(NS-14) E(2.J):C0T0 570 
SIS IF I J>3 T THeN ) PRINT ) TAB(NS-30) E(1.J) TAB(NS-14) «2.J) ELSE ORIOT 

«? ISIte 


“:Z4-".+ 

' :Z9“"USE <— TO 


»660:CG».1:CH»1.8:CJ 


660 


590 LOCATE NR.- „ 

595 LOCATE NR-2.1:PRINT RB; 

600 KQ«NS-17:KP*KL+1:J 9*3:GOTO 
610 LOCATE KP+1.KQ+1:PRINT Z; 

620 LOCATE NR-1.1 -.PRINT STRING$(NS-1, 

625 LOCATE NR-1.1:PRINT Z8; 

yWNKEYS-IF Y$*"" THEN 630 

lllf~ 

rWAWl locate KP41 ,KQ4l .PRINT Z3::0N JO OOTO 

690.680.710.680 
670 RETURN 

III KP-KP+J9:IF KP>KM+1 THEN KP-KL+1 ELSE IF KP<KL + 1 THEN KP-KM+1 
700 GOTO 750 

nl IF S=Ss-59 7 0r’kSnS-33 THEN KQ=KQ+16 ELSE KQ-NS-49 
740 IF T KQ-n1-33 THEN KQ=NS-17 ELSE KQ=NS-33 

i - “ ~ 

770 IF INSTR(RE.ZF) THEN KQ-NS-17 
780 GOTO 610 

in ;sSa?s'Sr:s:s«?'s?r.nc«ns-,.- ■>. 

805 LOCATE NR-1.1:PRINT Z9; 

III JoSfli'wtl.KOfl.PRINT ZA; :LOCATE KPtl .KQ4144.PRINT ZE;CHR$(95); 

IZ ^!S(» P Y V «):o't«N N .S UR(Y$)>- ANO ASC(RIGHT$(Y$, 1 ))*75 THEN 900 ELSE 
830 

850 ON INSTR(Z5,Y$) GOTO 900.920 
860 KC-KC+1 

880 L0CATE V KP+1,KQ+1+KC+3:PRINT Y$;CHR$(95); 

900 i? T Jc=0 0 THEN 830 ELSE KOKC-1:IF KC=0 THEN ZE="“ ELSE ZE=LEFT$(ZE.KC) 

910 GOTO 820 

920 KE*»(KQ-NS+49)/16 

US lSStE P ^®SrINT ZA;.LOCATE KR.1 ,K0.H3:PRINT CSHG(VAL(ZE)); 

950 ZE»"":J9*1 _ , 

960 IF KQ=NS-17 THEN KP=KP+1 
970 IF KP>KM+1 THEN KP=KL+1 
980 GOTO 710 
1490 REM Main program 


212 


BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 








July 


1500 GOSUB 6500 
1510 GOSUB 4610 
1520 GOSUB 3000 
1530 GOSUB 2000 
1540 GOSUB 2500 
1550 GOSUB 3500 
1560 GOSUB 4500 


* Introductory text 

* get title etc 
’get initial info 
’Input data 
’calculate critprops 
’results on screen 
’What next? 

1570 ON NC GOTO 1590,1600,1610,1610 
1580 CLS:ON ERROR GOTO 0:END 

1590 GOSUB 4000:GOTO 1560 * to hardcopy routine 
1600 GOSUB 5000:GOTO 1560 ’save to disk 

1610 FOR J«1 TO 2:FOR K»1 TO 8:E(J,K)=0:NEXT K,J 'clean out input array 
1620 ON NC-2 GOTO 1510,1520 
1990 REM Data input 
2000 CLS 

2010 RA»"INPUT DATA FOR "+YA 

2020 RB="DATA FOR SECOND VAPOUR PRESSURE POINT OPTIONAL" 

2030 RD="2,3,7," 

2040 RE-"1, M 
2050 J8-2 

2060 KL«1:KM»8:0N JF GOTO 2080,2080,2090 


2070 E( 
2080 E( 
2090 E( 


■CK*CN:GOTO 2100 
■CL:GOTO 2100 


1,4)-CM 


2100 ZZ(1)®Y(1):ZZ(2)*STRING$(NS-36," ")+"VaIue"+STRING$(9," 

.- — f 4 W(5)+" 

(7)-" - 


")+“Temperature":ZZ(3)«STRING$(43," ")+YT:ZZ(4 

- Y(6)+ M "--“ 


“+YP+"/"+YT:ZZ(5)-Y( 


"+YP:ZZ(6)-ZZ(5):ZZ( 


2110 GOSUB 500 ’to screen entry 
2120 M-E(2,1) 

2130 N-4 

2140 FOR J-0 TO 2 

2150 ON JF GOTO 2170,2180,2190 

2160 P(J)-E(1,J+N)/CN:T(J)-E(2,J+N)+CP:C»CN*CK:GOT0 2200 
2170 P(J)-E(1,J+N)*CK/CL:T(J)-E(2,J+N)+CP:C»CL:GOTO 2200 
2180 P(J)-E(l.J+N)*CK/CL:T(J)=(E(2,J+N)-CJ)/CH+CP:C-CL:G0T0 2200 


2190 P(J)«E(1,J+N)*CK/CM:T(J)-(E(2,J+N)-CJ)/CH+CP:C-CM 
2200 NEXT 

2210 SG«E(1,8):D«SG*CN 

2220 IF JF-2 OR JF-3 THEN T-(E(2,8)-CJ)/CH ELSE T-E(2,8) 
2230 T(3)-T+CP 
2240 RETURN 


2490 REM Calculation 
2500 CLS 

2510 PRINT"CaIcuI at Ing" 

2520 IF P(2)=0 THEN N-0 ELSE N-1 

2530 IF P(0)=0 THEN GOSUB 2710 ELSE TB-T(0):TO-T(0) 

2540 T1-C1*TD 
2550 FOR J-0 TO 1 
2560 TR(J)-T(N+J)/T1 

2570 F(J)-C2/TR(J)+C3*LOG(TR(J))-C4-TR(J)"6 

2580 NEXT 

2590 DF-F(0)-F(1) 

2600 AL-(L0G(P(N)/P(N+1))-C5*DF)/(L0G(T(N)/T(N+1))-C6*DF) 

2610 PC«EXP(LOG(P(N))-C5*F(0)-AL*(LOG(TR(0))-C6*F(0))) 

2620 VC-C7*T1/PC/(C8+C9*AL) 

2630 V(1)-VC/(CA+CB*AL) 

2640 TR(2)-T(3)/T1:V(2)-M*(CC-CD*TR(2)+CE*((1-TR(2))"(1/3)))/D 
2650 T2-T1+CF*(V(1)-V(2)) 

2660 IF ABS(T2-T1)<-CG THEN 2680 

2670 T1-T2:G0T0 2550 ’loop If not converged 

2680 PB(0)-T1:PB(1)-PC:P8(2)=VC*CN:PB(3)-.2033*AL-1.1816 

2690 RETURN 

2700 REM Estimate bpt by Antoine 
2710 B=LOG(P(1)/P(2))/(1/T(2)-1/T(1)) 

2720 A-LOG(P(1))+B/T(1) 

2730 TO-B/(A-LOG(C)) 

2740 RETURN 
2980 REM 


2990 PEM Compound name 

3000 INPUT"Name of compound":YA 

3010 IF JF THEN 3130 * J f le unit flag 

3020 PRINT:PRINT"WhIch unite are you using?" 

3030 PRINT:PRINT"1) mmHg and deg C" 

3040 PRINT"2) mmHg and deg F" 

3050 PRINT"3) pel a and deg F" 


[continued) 
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3060 PRINT“4) kPa and dag C" 

3070 NC-4:G0SUB 6070 
3080 JF-NC:ON JF GOTO 3100,3110,3120 
:GOTO 3130 
:GOTO 3130 
:GOTO 3130 

):YT«Y(8) 

3130 RETURN 
3490 REM Display results on screen 
3500 CLS 

3510 YC-"CRITICAL PROPERTIES OF "+YA:J«(NS-LEN(YC))/2 
3520 PRINT TAB(J);YC 
3530 PRINT 

3540 J«(NS-40)/2:K«(NS+30)/2 


3090 YP-YI 

;i2; 

): YT-YI 

J9) 

3100 YP-YI 

10 

):YT-YI 

9) 

3110 YP-YI 

10 

I: YT-YI 

8) 

3120 YP-YI 

:i i: 

1:YT-YI 

[8) 


3550 PRINT TAB 
3560 PRINT TAB 


JV'C 

0 M c 


(K) USING Y1;PB(0) 
(K) USING Y3;PB(1) 


’check if printer ready 


Critical temperature, K:";:PRINT TAB(K) 

. Critical pressure, MPa:";:PRINT TAB(k, _ 

3570 PRINT TAB(J+19)"atma: M ;:PRINT TAB(K) USING Y1;PB(1)/CK 
3580 PRINT TAB(j)“Crit leal volume, cc/moI: M ;:PRINT TAB(K) USING Y1;PB(2) 
3590 PRINT 

3600 PRINT TABf JV'PI tzer acentric factor :";:PRINT TAB(K) USING Y2;PB(3) 
3610 PRINT TAB(j)"Rledel critical parameter :“;:PRINT TAB(K) USING Y2;AL 
3620 GOSUB 6030 
3630 RETURN 

3990 REM printer output 
4000 CLS 

4010 J«PEEK(14312) AND 240 
4020 IF J-48 THEN 4060 

4030 PRINT"PrInter not on line - press <ENTER> when ready" 

4040 Y«INKEY$:IF Y*““ THEN 4040 
4050 GOTO 4000 
4060 IF LP THEN 4370 

4070 PRINT"If you are going to calculate properties for several 
substances":PRINT"the results can be printed as a table." 

4080 PRINT"Otherwise they will be printed with each set as a 
separate":PRINT"report." 

4090 PRINT"Press <T> for tabulated results, <S> for separate reports": 

4100 YR-"TtSs":GOSUB 6010 
4110 LP-(KA<3) 

4120 LPRINT TAB(10)"ProJect: ";YB;TAB(70);YD:LPRINT 
4130 IF LP THEN 4270 
4140 REM Single printout 
4150 J»(80-LEN(YC))/2:LPRINT TAB(J);YC 
4160 LPRINT 

4170 LPRINT TABf18)"Cr11lea I temperature, K:";:LPRINT TAB(55 
4180 LPRINT TAB(18)"Crltical pressure, MPa:";:LPRINT TAB(55 
4190 LPRINT TABf37V'atma:";:LPRINT TAB(55) USING Y1;PB(1)/.10133 
4200 LPRINT TAB(18)"Cr11lea I volume, cc/moI:";:LPRINT TAB(55) USING Y1;PB(2) 
4210 LPRINT V ’ 

4220 LPRINT TAB(18)"Pitzer acentric factor :“;:LPRINT TAB(55) USING Y2;PB(3) 
4230 LPRINT TAB(18)"R!edel critical parameter :";:LPRINT TAB(55) USING 
Y2:AL:GOTO 4240 V ' 

4240 LPRINT:LPRINT TAB(10)"These properties calculated using the method of 
Rummens and Rajan":LPRINT TAB(10)"with the following Input data:":LPRINT 
4250 LPRINT TAB(18)"Moleculor weight";:LPRINT TAB(55) USING Y3;M 
4260 IF P(0) THEN LPRINT TAB(18) Y(5)+" "+YT;:LPRINT TAB(55) USING Y1;E(2,4) 
4270 LPRINT TAB(18) ZZ(5);:LPRINT TAB(45) USING Y2+" "+YP+" @"+Y1+" 

“+YT;E(1,5),E(2,5) 

4280 IF E(1,6) THEN LPRINT TAB(18) ZZ(6);:LPRINT TAB(45) USING Y2+" "+YP+" 
@"+Y1+" "+YT;E(1,6),E(2,6) 

4290 LPRINT TAB(18)ZZ(8);:LPRINT TAB(45) USING Y2+" g/cc"+" @"+Y1+" 

"+YT;E(1,8),E(2,8) 

4300 LPRINT CHR$(12) 

4310 GOTO 4380 

4320 REM Tabular printout 

4330 LPRINT TAB(10)"Name";TAB(50)"Cr111caI";TAB(70)”Acent rIc" 

4340 LPRINT TAB(40)"TempTA8(50)"Pressure";TAB(62)"Vo Iume";TAB(70)"factor" 
4350 LPRINT TAB(40)" K";TAB(49)"MPa atm";TAB(62)"cc/moI" 

4360 LPRINT 

4370 LPRINT TAB(10);YA;:LPRINT TAB(40) USING Y1;PB(0);:LPRINT TAB(47) USING 
Y3;PB(1);:LPRINT TAB(55) USING Y1;P8(1)/.10133;:LPRINT TAB(62) USING 
Y1;PB(2);:LPRINT TAB(70) USING Y2;PB(3) 

4380 RETURN 
4490 REM Menu 
4500 CLS 

4510 LOCATE 1,NS/2-3:PRINT "WHAT NEXT" 


USING Y1;PB(0) 
USING Y3;PB(1; 
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4520 PRINTiPRINT TAB(10)"1) Hardcopy of results 11 

4530 PRINT TAB(10)“2) Save critical properties to disk 11 

4540 PRINT TAB(10)"3) New project 11 

4550 PRINT TAB(10) 11 4) Calculate another material 11 

4560 PRINT TAB(10)"5) End program 11 

4570 NC-5:GOSUB 6070 

4580 RETURN 

4600 REM Project intro routine 

4610 CLS:LP-0:JF=0:INPUT"Enter project title M ;YB 

4620 YD*LEFT$(DATE$, 10) :PRINT"Project date (default * 11 ; YD; 11 ) 11 INPUT YD 
4625 IF YD* 1111 THEN YD=LEFT$(DATE$, 10) 

4630 RETURN 

4990 REM Save critical data 

5000 GOSUB 5240:GOSUB 5120:GOSUB 5170 

5010 CLS:PRINT M Saving to file M ;Y 

5020 IF N>L0F(1 )/LF THEN LSET XF$»STRING$(64, 11 M ) 

5030 LSET NF$-YH 

5040 LSET MF$=MKS$(M):LSET BF$=MKS$(TB) 

5050 LSET TF$=MKS$(PB(0)):LSET PF$«MKS$(PB(1)/.10133) 

5060 LSET VF$=MKS$(PB(2)):LSET WF$=MKS$(PB(3)) 

5070 LSET DF$=MKS$(SG):LSET SF$=MKS$(T) 

5080 PUT 1,N 

5090 CLOSE 1 

5100 GOSUB 6250:RETURN 

5110 REM Open file for crit data 

5120 Y-LEFT$(YH, 1) +"CRIT.DAT 11 

5130 OPEN"R",1,Y,128 

5140 FIELD 1,32 AS NF$,4 AS MF$,4 AS BF$,4 AS TF$,4 AS PF$,4 AS VF$,4 AS WF$,4 
AS DF$,4 AS SF$,64 AS XF$ 

5150 RETURN 

5160 REM Find if name in record 
5170 N-1 

5180 IF N>LOF(1)/LF THEN 5220 
5190 GET 1,N 

5200 J-LEN(YH):K-LEN(NF$):IF LEFT$(NF$,J)«YH THEN IF RIGHT$(NF$,K 
-J)«STRING$(K-J, 11 M ) THEN 5220 
5210 N«N+1:G0T0 5180 
5220 RETURN 

5230 REM Convert name to caps 
5240 YH-YA 

5250 FOR J-1 TO LEN(YA) 

5260 K-ASC(MID$(YA,J)) 5270 IF K>96 AND K<123 THEN YL=CHR$(K-32):MID$(YH,J)-YL 

5280 NEXT 

5290 RETURN 

5990 REM Subroutines 

6000 YR-"YyNn 11 

6010 Y-INKEY$: IF Y- 1111 THEN 6010 

6020 KA»INSTR(YR,Y): IF KA THEN PRINT 11 11 ;Y:RETURN ELSE 6010 
6030 LOCATE NR-1.1:PRINT "PRESS ANY KEY TO CONTINUE"; 

6040 Y«INKEY$: IF Y- 1111 THEN 6040 
6050 CLS 
6060 RETURN 

6070 PRINT:PRINT"Choose by number 11 ; 

6080 Y«INKEY$: IF Y-" 11 THEN 6080 
6090 Y%-VAL(Y) 

6100 IF Y%<1 OR Y%>NC THEN 6080 
6110 PRINT Y:NC«Y% 

6120 RETURN 
6130 CLS 

6140 IF ERR-5 THEN 6160 

6150 PRINT"Error in line";ERL:ON ERROR GOTO 0:RESUME 
6160 PRINT"Math error has occurred in line";ERL 

6170 PRINT"Program will return to data entry to allow you to re-enter your 
input data." 

6180 PRINT"Look for very low or very high, zero or negative values 
of "’.PRINT 11 Input data." 

6190 PRINT"Check that input data units are correct, and that all values 
arewithin the range of the correlation." 

6200 GOSUB 6030: RESUME 1530 
6240 REM Delay 

6250 FOR J-1 TO 4000:NEXT:RETURN 
6490 REM Opening text 
6500 CLS 

6510 PRINT"This program calculates the critical properties and 
acentric":PRINT"factors for many compounds.":PRINT 


[miimed) 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 215 





July 


6600 PRINT"It Is based on the correlation by Rummens and Rajan, 

published":PRINT"In the Can.J.Ch.E., Jun 1979, (Vol 57, No.3), page 349." 

6610 PRINT:PRINT"Input data required are the molecular weight, the vapor" 

6620 PRINT"pres8ure at any two temperatures, and the density at 

any":PRINT"temperature." 

6630 PRINT:PRINT"One of the vapor pressure points may be the normal 

bolIIng":PRINT"polnt, although the authors recommend against this, 

and":PRINT"suggest two other points 40 to 60 K apart will give best results" 

6640 GOSUB 6030 

6650 RETURN 


ascstr.asm 

"Structural Analysis." by Robert W. Johnson and Fernando 
G. LoygorrI. July, page 199. 


TITLE ASCSTR - FUNCTION TO DETERMINE ASCII CODE 
PAGE ,132 


; (C) Copyright Microstress Corporation 1984, 1985, 1986 


COMMENT * 

ASCSTR is a routine designed to be called from FORTRAN as a function 
to return the ASCII code of the character specified by the input. 


Mode of use: 
where 


code * ASCSTR (I,string) 


* 


code « value returned by the function, the requested ASCII code. 
I ■ Index to specify the location in the string of the character 
whose ASCII code is requested. 

string - name of the string (variable of type CHARACTER) where 
the requested character is located. 


SUBTTL FORMAL DECLARATIONS 
PAGE 


csascs SEGMENT 'CODE* 

ASSUME CS:csascs 

SUBTTL ASCSTR - EXECUTABLE CODE 
PAGE 

PUBLIC ascstr 
ascstr PROC FAR 

PUSH BP 

MOV BP,SP 

PUSH ds 

LDS BX,DWORD PTR [BP+10] 

MOV CX,[BX] 

; Check positive request, 
cmp cx,0 

jle outbounds 

; Locate the end of the string (logical or physical) 
LDS BX,DWORD PTR [BP+6] 

scanend: 

mov a I,[bx] 

cmp a I,0 

Je outbounds 

cmp a I,6 

je outbounds 

inc bx 

loop scanend 

; Value is returned In AX. 

XOR AH,AH 

jmp exit 

; Handle a request out of bounds, 
outbounds: 

xor ax.ax 

exit: 

POP ds 
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MOV 

SP.BP 


POP 

BP 


RET 

8h 

ascstr 

ENDP 


csascs 

ENDS 



END 


test.seq 

"Analog Circuit Analysis," by David McNeill. 

July, page 170. See ac.prg for detaiIs.Commodore 64 


%14 

* TEST CIRCUIT 

* 

* FILE NAME IS TEST 

* 

R1 1 2 10K 

R2 2 3 40K 

R3 4 3 4K 

Cl 2 3 100PF 

VIN 1 0 -2 DC 1 0 AC 

VCC 4 0 20 DC 

Q1 3 2 0 1 

.MODEL 1 NPN BF-50 BR-1 IS-1E-14 VA=100 CJE-2PF CJC-4PF 
.OUT 4 V(3) V(3)/(VIN) ZIN(VIN) Z0UT(3) 

.END 


testdc.seq 

"Analog Circuit Analysis," by David McNeill. 
July, page 170. See ac.prg for details. 


7 . 

0 . 

0 . 

V(3)/(VIN) 

6 , 

0 . 

0 . 

ZIN(VIN), 

R1, 

0 . 

0 . 

Z0UT(3), 

R2, 

3 . 

.02 . 

1 . 

R3, 

-2 . 

1 . 

2 . 

Cl. 

1 . 

.01 . 

3 . 

VIN, 

0 , 

IE-14 , 

4 . 

VCC. 

5 . 

1 . 

0 . 

Q1» 

1 . 

1 . 

0 . 

1 . 

0 . 

2E-12 . 


10000 , 

3 , 

4E-12 , 


1 . 

20 . 

6E-10 . 


2 . 

4 . 

6E-09 . 


0 . 

0 . 

1 , 


0 , 

6 . 

1 . 


0 • 

0 . 

1.0.0. 


1 . 

0 . 

4 . 


40000 , 

5 . 

-5 . 


2 . 

3 . 

3 . 


3 . 

2 , 

0 . 


0 . 

0 . 

0 . 


0 . 

1 . 

5 . 


0 . 

0 . 

0 . 


1 . 

1 . 

3 . 


4000 , 

1 . 

0 . 


4 , 

0 . 

-2 . 


3 . 

0 . 

5 . 


0 . 

0 . 

0 . 


0 , 

0 , 

0 . 


0 , 

0 . 

-1 . 


10 . 

0 . 

3 . 


IE-10 , 

0 . 

0 . 


2 , 

0 . 

0 . 


3 . 

0 . 

V(3). 
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truss2.bas 

"Engineering on o Micro." Chris Pedicinl. July, poge 145. 


PROGRAM - TRUSS2: VERSION 1.0: COPYRIGHT 1984 - C.S. PEDICINI 


DIM XNOD(100),YNOD(100).NCON(100,2).AR(100) 

DIM A(200.25),B(200),STR(100) 

DIM XXYY(4),BK(4,4) 

DIM EKEY(5),NUM(10,10),NDIG(6),MARKER(10),ID(3,7),NMK(6) 
DIM IL0AD(100,2),RLOAD(100),MENUS(4,7),PRNT$(5) ^ 

’ DATA FOR GRAPHICS 


10 
20 
30 

40 ON ERROR GOTO 22000 
50 DEFINT I-N 
60 GOSUB 20000 
70 • 

80 ‘ DIMENSION VARIABLES 
90 
100 
110 
120 
130 
140 
150 
160 
170 

180 DATA 6.6.12288.18504.12360 
190 DATA 6,6.8192,8224.8224 
200 DATA 6,6.12288,4168.30752 
210 DATA 6.6,30720,14344,30728 
220 DATA 6,6,18432.30792,2056 
230 DATA 6,6,30720.30784,30728 
240 DATA 6,6,30720,30784,30792 
250 DATA 6,6,30720,2120.2056 
260 DATA 6,6,12288,12360.12360 
270 DATA 6.6.30720.30792,30728 
280 * 

290 DATA 9,9,0.48.48,252.48,48,0.0 
295 DATA 7.7.14336.-258,14590.0,0 
300 ' 

310 * DATA FOR SPREADSHEET EDITOR 
320 ’ 

330 DATA 1.8,10,10,10,20 
340 DATA 1.8.6,6,6.18 
350 DATA 1,8,1,1,10,18 
360 * 

370 DATA "MAIN MENU","DATA EDITOR"."GRAPHICS"."PRINT DATA" 
"ANALYSIS/RESULTS", "GET/SAVE/DELETE"."QUIT" 

380 DATA "FEM DATA EDITOR"."EDIT NODES","EDIT ELEMENTS"."EDIT LOADS" 

"FIND BANDWIDTH","CONTROL CARDS","" 

390 DATA "GRAPHICS","ORIGINAL GEOMETRY"."FINAL GEOMETRY","STRESS PLOT”, 

"DELETE" "m E Ih S hY E/DELETE,,,,,GET DATA “ FEM MODEL", "SAVE DATA. FEM MODEL", 
420 * 

430 • READ DATA 
440 * 

450 FOR 1-1 TO 10: FOR J=0 TO 4: READ NUM(I,J): NEXT J: NEXT I 
460 FOR 1=0 TO 9: READ MARKER(I): NEXT I 

465 FOR 1-0 TO 6: READ NMK(I): NEXT I 

470 FOR K=1 TO 3: FOR J=1 TO 6: READ ID(K,J) : NEXT J: NEXT K 

480 FOR 1-1 TO 4: FOR J-1 TO 7: READ MENU$(I,J): NEXT J: NEXT I 

485 FOR 1-1 TO 5: PRNT$(I)»"Y": NEXT I 

490 • 

500 * INITIALIZE VARIABLES 
510 * 

520 BLANK$=" 

530 FKEY$»" ESC = RETURN TO MENU, FI = DELETE LINE. 
"+CHR$(27)+CHR$(24)+CHR$(25) +CHR$(26)+" POSITION CURSOR" 

540 MAXNP-100: MAXEL-100: MAXLD-100: MBW-30 
DV$«"A:": DAT1$*DATE$: EXAG-1 
EKEY(1)«30000000#: EKEY(2)=30000 
IERR-0: NLOAD-0: NUMNP-0: NUMEL-0 
FOR 1-1 TO MAXEL 
AR(I)«1I 
NEXT I 


550 

560 

570 

572 

574 

576 

580 

590 

600 


MAIN MENU 
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610 IMENU-1: GOSUB 25000: IOPT-ISEL 
620 IF IRETO0 THEN GOTO 610 

630 ON IOPT GOSUB 650,3460,31000,10000,5610.24010 

640 GOTO 610 

650 ' 

660 ’ DATA EDITOR MENU 
670 • 

680 IMENU-2: GOSUB 25000: IOPT2-ISEL 

690 IF IRETO0 THEN RETURN 

700 ON IOPT2 GOSUB 730,780,830,880,3070 

710 GOTO 680 

720 1 

730 • EDIT NODES 
740 1 

750 NCUR-NUMNP: NLMT-MAXNP: K-1: GOSUB 950 
760 NUMNP-NCUR: ID(K,1)«NFRST: RETURN 
770 • 

780 • EDIT ELEMENTS 
790 * 

800 NCUR-NUMEL: NLMT-MAXEL: K-2: GOSUB 950 
810 NUMEL-NCUR: ID(K,1)«NFRST: RETURN 
820 ' 

830 * EDIT LOADS 
840 * 

850 NCUR-NLOAD: NLMT-MAXLD: K-3: GOSUB 950 
860 NLOAD-NCUR: ID(K,1)«NFRST: RETURN 
870 ' 

880 # CALCULATE BANDWIDTH 
890 ’ 

900 CLS 

910 GOSUB 30000 

920 LOCATE 12,30: PRINT USING "MAX BANDWIDTH * ###";BW 

930 LOCATE 16,27: PRINT "PRESS ANY KEY TO CONTINUE" 

940 A1$«INKEY$: IF A1$-"" THEN 940 ELSE RETURN 
950 • 

960 ’ ** FULL SCREEN EDITOR ** 

970 ’ 

980 



990 

1000 

1010 

1020 

1030 

1040 

1050 


LOCATE 24,15 


1060 GOSUB 2840 
1070 * 

1080 * ** SPREADSHEET CONTROL INPUT ** 

1090 ' 

1100 A1$-INKEY$ : IF A1$«"" THEN GOTO 1100 
1110 IF ASC(A1$)«27 THEN RETURN 

1120 IF LEN(A1$)-2 THEN A2«ASC(RIGHT$(A1$,1)): GOSUB 1150 ELSE GOSUB 1330 
1130 GOTO 1050 
1140 • 

1150 •** CURSOR KEYS ** 

1160 • 

1170 IF A2-59 THEN GOSUB 1880: RETURN 

1180 IF A2-80 OR A2-72 THEN GOSUB 2390: RETURN 

1190 IF A2«77 AND NCOL<MXCOL THEN GOSUB 2950: NCOL-NCOL+NLEN: RETURN 

ELSE IF A2-77 THEN RETURN 

1200 IF A2-75 AND NCOL>MNCOL THEN GOSUB 2950: NCOL-NCOL-NLEN: RETURN 
ELSE IF A2-75 THEN RETURN 
1210 • 

1220 ’** PgUp..PgDn..Home..End ** 

1230 * 

1240 IF A2-81 AND NFRST<«NCUR-15 THEN NFRST-NFRST+15 ELSE IF A2-81 
THEN NFRST-NCUR 

1250 IF A2-73 AND NFRST>15 THEN NFRST-NFRST-15 ELSE IF A2-73 THEN NFRST-1 

1260 IF A2-71 THEN NFRST-1: 'HOME 

1270 IF A2-79 THEN NFRST-NCUR: 'END 

1280 IF A2-81 OR A2-73 OR A2-71 OR A2-79 THEN GOSUB 2950: COLOR 7,0: 

GOSUB 2140: RETURN 
1290 ' INPUT ERROR 

1300 MSG$«"INVALID KEY ENTRY":SCREEN 0.0.1,1 
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GET NUMERIC VALUE 


1310 GOSUB 26000: SCREEN 0.0,0,0: LOCATE 24,1: PRINT BLANK$;: LOCATE 24,4 
PRINT "COMMAND = :RETURN 

1320 ' 

1330 ' ** ALTER NUMERIC VALUE ** 

1340 * 

1350 
1360 
1370 
1380 
1390 
1400 
1410 
1420 
1430 


X-24: Y-15: GOSUB 21090 
IF IERR-1 THEN RETURN 
NR-NFRST+NROW-8 
IF NR>NLMT THEN RETURN 
ON K GOSUB 1450.1490,1530 

IF NR>NCUR THEN NCUR-NCUR+1: LOCATE 3,53: PRINT USING "###"-NCUR 
LOCATE NROW.1: I-NR: GOSUB 2640 

IF NR-NCUR AND NROW<21 THEN I-NCUR+1: LOCATE NROW+1,1: GOSUB 2640 
IF NCOL<MXCOL THEN GOSUB 2970: NCOL-NCOL+NLEN: RETURN 
ELSE IF NROW<-21 THEN GOSUB 2970: NCOL-MNCOL: 

NROW-NROW+1:RETURN 
1440 RETURN 

1450 * VALUE ALTERATION NODES 
1460 NC- INT(NCOL/10)+1 

1470 IF NC-2 THEN XNOD(NR)-VALNEW: ELSE IF NC-3 THEN YNOD(NR)-VALNEW 
1480 RETURN V ' 

1490 • VALUE ALTERATION ELEMENTS 
1500 NC- INT(NC0L/6)+1 

1510 IF NC-2 THEN NCON(NR,1)-VALNEW: ELSE IF NC-3 THEN NC0N(NR,2)-VALNEW- 
ELSE IF NC-4 THEN AR(NR)-VALNEW 
1520 RETURN 

1530 ’ LOAD VALUE ALTERARION 
1540 NC- INT(NC0L/9)+1 

1550 IF NC-1 THEN ILOAD(NR,1)-VALNEW: ELSE IF NC-2 THEN ILOAD(NR,2)-VALNEW- 
ELSE IF NC-3 THEN RLOAD(NR)-VALNEW 
1560 RETURN 
1570 * 

1580 * PAGE HEADERS 
1590 1 

1600 CLS: LOCATE 25,5: PRINT FKEY$; 

1610 LOCATE 1,(80-LEN(TITLE$))/2: PRINT TITLE$ 

1620 LOCATE 2.2:PRINT USING "PAGE = ##";PAGE 

1630 IF K-1 THEN A1$-"NODE" ELSE IF K-2 THEN A1$-"ELEMENT" ELSE IF K-3 

THEN A1$-"LOAD" 

1640 A1$-A1$+" EDITOR" 

1650 LOCATE 2.(80-LEN(A1$)-8)/2: PRINT "... ";A1$;" ...»: LOCATE 2,70: 
PRINT DAT1$ 

1660 LOCATE 3,25: PRINT USING "CURRENT NUMBER OF ENTRIES - ###":NCUR 
1670 ON K GOSUB 1690,1710.1750 
1680 RETURN 

1690 •** HEADER FOR NODES ** 

1700 PRINT : PRINT: PRINT " NODE 
1710 •** HEADER FOR ELEMENTS ** 

1720 PRINT 

1730 PRINT " ELEM NODE NODE SECTION" 

1740 PRINT "NO. I J AREA": RETURN 

1750 ’** HEADER FOR LOAD EDITING ** 

1760 PRINT:PRINT: PRINT " NODE I-CODE 
ICOL-40 

LOCATE 8.IC0L: FOR I-ICOL TO 75: PRINT 
LOCATE 10,ICOL:PRINT "** I-CODE 
LOCATE 12,ICOL:PRINT 
LOCATE 13.ICOL:PRINT 


1770 

1780 

1800 

1810 

1820 

1830 

1840 

1850 

1860 

1870 

1880 

1890 

1900 

1910 

1920 


X-COORD Y-COORD " : RETURN 


LOAD VALUE" 


LOCATE 14,ICOL:PRINT "** 
LOCATE 15,ICOL:PRINT "** 


LOCATE 17,ICOL: 
RETURN 

l 

’ DELETE A LINE 


NEXT I 

MEANING **" 

0 FORCE IN X DIRECTION **" 

1 FORCE IN Y DIRECTION **" 

2 FIXITY IN X DIRECTION *“ 

3 FIXITY IN Y DIRECTION *" 


FOR I-ICOL TO 75: PRINT 


NEXT I 


LOCATE 24,1 : PRINT "TO DELETE THIS LINE PRESS. Y 
IN$-INKEY$ : IF IN$-"" THEN 1910 

IF IN$-"Y" OR IN$-"y" THEN GOSUB 2950: GOTO 1930 ELSE RETURN 
1930 LOCATE 24,1 : PRINT BLANK$; : LOCATE 24,1 : PRINT "DELETION BEGINNING 
1940 IF NFRST+NR0W-8>NCUR THEN RETURN 
1950 FOR I-NFRST+NR0W-8 TO NCUR 

1960 IF I-NLMT THEN 2080 

1970 ON K GOTO 1980.2010,2040 

1980 * DELETE NODAL VALUES 
1990 XNOD(I)-XNOD(1+1): YNOD(I)-YNOD(I+1) 

2000 GOTO 2080 

2010 • DELETE ELEMENT VALUES 


220 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 



July 


2020 AR(I)=AR(I+1): NCON(I.1)-NC0N(I+1.1): NCON(I,2)-NC0N(I+1.2) 

2030 GOTO 2080 

2040 ‘ BEGIN MODULE DELETE CURRENT LINE 
2050 ILOAD(I,1)-ILOAD(I+1,1) 

2060 ILOADfl,2)-ILOAD(I+1,2) 

2070 RLOAD(I)- RLOAD(I+l) 

2080 NEXT I 

2100 COLOR^©: 1 LOCATE 3,53: PRINT USING "###";NCUR 
2110 GOSUB 2140 
2120 RETURN 
2130 * 

2140 * FULL DATA LIST 

2160 DEF SEG -4HB800: FOR 1-1120 TO 3360 STEP 160: FOR J-0 TO (MXCOL+NLEN)*2 

STEP 2: POKE I+J.0: NEXT J: NEXT I: DEF SEG 

2170 LOCATE 8,1: NROW-8: IF NCUR<14 THEN NFRST-1 

2180 ON K GOSUB 2200.2260.2330 

2190 RETURN 

2200 ’ ** NODE POINTS ** 

2220 F IF I>NCUR+1 T OR N I>NLMT THEN 2240 ELSE IF I-NCUR+1 THEN 

2230 T US WNT US?NG « "### ^^“^PRINT USING - ###•####": XNOD(I) .YNOD(I) 

2240 NEXT I 

2250 RETURN 

2260 * ** ELEMENTS ** 

2280 F IF I>NCUR+1 T 0R NF >NLMT 4 THEN 2310 ELSE IF I-NCUR+1 THEN 

S T US m N ; ‘iiP^^C.D.NCONO.M, 

2300 PRINT USING n ###.##“;AR(I) 

2310 NEXT I 
2320 RETURN 
2330 * ** LOADS ** 

2340 FOR I-NFRST TO NFRST+14 

2350 IF I>NCUR+1 OR I>NLMT THEN 2370 

2360 PRINT USING 11 ### ";ILOAD (1,1),ILOAD(1,2);: 

PRINT USING "######•###"; RLOAD(I) 

2370 NEXT I 
2380 RETURN 
2390 
2400 
2410 
2420 
2430 
2440 
2450 
2460 
2470 
2480 
2490 
2500 


> HANDLE UP/DOWN SCROLLING...AND MOVING CURSOR 
* 

IF A2-80 THEN 2530 

• SCROLL DOWN 

IF NR0W>8 THEN GOSUB 2940: NROW-NROW-1: RETURN 
IF NROW-8 AND NFRST-1 THEN RETURN ELSE NFRST-NFRST-1 

» 

• SCROLL DOWN START AT 8 GOTO 23 ADD A LINE 


FOR 1*3200 TO 1120 STEP -160: FOR J=0 TO (MXCOL+NLEN)*2 STEP 2: 
I1*PEEK(I+J): POKE I+J+160,I1: NEXT J: NEXT I 
2510 DEF SEG 

LOCATE 8.1: I-NFRST: GOSUB 2640: RETURN 
SCROLL UP 

IF NFRST+NR0W-8-NCUR+1 THEN RETURN 
IF NROW<22 THEN GOSUB 2940: NROW-NROW+1: RETURN 
NFRST-NFRST+1 


2520 

2530 

2540 

2550 

2560 

2570 

2580 

2590 

2600 

2610 


SCROLL UP START AT 8 GOTO 14 ADD A LINE 


FOR 1-1280 TO 3360 STEP 160: FOR J-0 TO (MXC0L+NLEN)*2 STEP 2: 
I1-PEEK(I+J): POKE I+J-160,11: NEXT J: NEXT I 
2620 DEF SEG 

LOCATE 22,1: I-NFRST+14: GOSUB 2640: RETURN 


2630 
2640 
2650 
2660 
2670 
2680 
2690 
RETURN 


• LIST 1 LINE OF DATA AT .I. 

i 

ON K GOSUB 2680.2720.2770: RETURN 

• ** EDIT NODES ** 

IF I-NCUR+1 THEN PRINT USING H 


M 


"Si: 
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M M;s PRINT USING - ###.####'*; 


2720 

2730 

2740 

2750 

2760 

2770 

2780 


2700 PRINT USING 

XNOD(I),YNOD(I) 

2710 RETURN 

** EDIT ELEMENTS ** 

IF I-NCUR+1 THEN PRINT USING “ ### 

PRINT USING " m "11,NCON(1,1),NCON(I,2); 

RETURN 1 ” USING 
** EDIT LOADS ** 

PRINT USING " §§§ ILOAD (1,1),ILOADfI 2) •• 

PRINT USING "######.###"' RLOAD I) U.1).ILOAO(I,2).. 

2790 RETURN 
2800 • 

2®’® ! HIGHLIGHT AN AREA ON THE SCREEN AT CURRENT 

2®2® , CURSOR LOCATION (NROW.NCOL) LENGTH -NLEN 

2830 

2840 COLOR 0,7 
2850 F$-"" 

2860 FOR L-1 TO NLEN 

2870 LOCATE NROW.NCOL+L 

2880 C$-CHR$(SCREEN(NROW.NCOL+L)) 

2890 PRINT C$ 

2900 NEXT L 
2910 COLOR 7,0 
2920 RETURN 
2930 ’ 

2940 ’ REMOVE HIGHLIGHT ON THE SCREEN AT CURRENT 

2950 * CURSOR LOCATION (NROW.NCOL) LNEGTH-NLEN 

2960 • 

2970 COLOR 7.0 
2980 F$»"" 

2990 FOR L-1 TO NLEN 

3000 LOCATE NROW,NCOL+L 

3010 C$=CHR$(SCREEN(NROW,NCOL+L)) 

3020 PRINT C$ 

3030 NEXT L 
3040 COLOR 0,7 
3050 RETURN 
3060 • 

CONTROL CARDS 


"; I: RETURN 


X-3: Y-8 

CLS: LOCATE 1,25: PRINT "TRUSS CONTROL VARIABLES" 

i'Ar*rl lf’f : noJKI " USE UP / D0WN ARROWS TO POSITION CURSOR AND ENTER " 
16,5: PRINT Y0UR VALUE - USE RETURN KEY TO TERMINATE THE ENTRY" 
LOCATE 18,5: PRINT " <Esc> RETURNS TO MENU" 

PRINT "TITLE: ";TITLE$ 


3070 
3080 
3090 
3100 
3110 
3120 
3130 
3140 
3150 
3160 
3170 
3180 
3190 
3200 
3210 
3220 
3230 
3240 

GOTO 3270 ELSE GOTO 3210 


LOCATE 3.1: 
LOCATE 5.1: 
LOCATE 7,1: 
LOCATE 9,1: 

* TRAP KEYS 
» 

LOCATE X, Y,1 
A1$*INKEY$: 


PRINT 

PRINT 

PRINT 


"DATE : ";DAT1$ 

"ELASTIC MODULUS (PSI) : ";EKEY(1) 
"DESIGN STRENGTH (PSI) : ";EKEY(2) 


rr tu? ii^ IF o A ^u"Jt! EN 3220 ELSE IF ASC(A1$)»27 THEN 3400 
IF LEN(A1$)<>2 THEN GOTO 3300 

if A1 “ 72 then goto 3250 ELSEIF A1=80 then 


3250 

3260 

3270 

3280 

3290 

3300 

3310 

3320 

3330 

3340 

3350 

3360 

3370 

3380 

3390 

3400 

3410 

3420 

3430 


IF X>7 THEN 
GOTO 3210 
IF X>«5 AND 
GOTO 3210 


X=CSRLIN-2: Y«26: ELSE IF X<*7 AND X>3 THEN X=CSRLIN-2: Y=8 
X<9 THEN X-CSRLIN+2: Y«26: ELSE IF X«3 THEN X=5: Y=8 


VALUE ENTERED 

IF ASC(A1$)<»32 OR ASC(A1$)>127 THEN GOTO 3140 
PRINT A1$; :X«CSRLIN 

THEN LINE INp UT;TITLE$ :TITLE$»A1$+TITLE$ 


IF CSRLIN-5 THEN LINE INPUT;DAT1$ 
IF CSRLIN-7 THEN LINE INPUT;A2$ 

IF CSRLIN-9 THEN LINE INPUT;A2$ 

IF X<»5 THEN Y*8 ELSE Y-26 
GOTO 3140 

• 

CHECK VALIDITY OF ENTRIES 


DAT1$-A1$+DAT1$ 
:EKEY(l)-VAL(A1$+A2$) 
:EKEY(2)-VAL(A1$+A2$) 


IF EKEY(1)<1 OR EKEY(2)<1 THEN MSG$-"INVALID PROPERTIES": 
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GOSUB 26000 :GOTO 3100 

3440 IF LEN(DAT1$)<>10 THEN MSG$*"INVALID DATE SPECIFICATION": 
GOTO 3100 


GOSUB 26000 


3450 

3460 

3470 

3480 

3490 

3500 

3510 

3520 

3530 

3540 

3550 

3555 

3560 

3563 

3565 

3567 

3568 
3570 
3575 
3580 
3585 
3590 
3600 
3610 
3620 


RETURN 


GRAPHICS 


IMENU=3: GOSUB 25000: I0PT3-ISEL 
IF IRETO0 THEN RETURN 
GOSUB 3540 
GOTO 3490 


GRAPH MESH 


IF I0PT3*1 THEN EXAG=0: GOTO 3570 
CLS• LOCATE 5 1 

PRINT " ENTER AN EXAGGERATION RATIO FOR THE NODE DEFLECTIONS" 
PRINT " IF YOU ENTER A ONE THEN STRUCTURE DISTORTION WILL BE 
PRINT " TO SCALE..."; ‘.INPUT EX AG 
IF EXAG<0 THEN EXAG-0 
CLS: LOCATE 12.30: PRINT "THINKING" 


DETERMINE MAX/MIN 


XMIN-XNOD(l)+EXAG*B(1): YMIN=YNOD(1)-EXAG*B(2): XMAX-XMIN: YMAX-YMIN 

F ?F IOPT3*1 N THEN DXI®0: DYI*0 ELSE DXI«EXAG*B(I*2-1): DYI-+EXAG*B(1*2) 
IF XMIN>XNOD(I)+DXI THEN XMIN«XNOD(I)+DXI ELSE IF XMAX<XNOD(I)+DXI 

3630 IF YMIN>YNOD(I)+DYI THEN YMIN*YNOD(I)+DYI ELSE IF YMAX<YNOD(I)+DYI 
THEN YMAX«YNOD(I)+DYI 

3650 IF E XMIN«XMAX OR YMIN-YMAX THEN MSG$*"NODAL COORDINATE ERROR": 

GOSUB 26000: RETURN 
3652 * 

FIND MAXIMUM SCALE AND ALTER MAX/MIN TO FIT 


3654 

3656 

3660 

3670 

3675 

3677 

3679 

3680 

3681 
3690 
3700 
3710 
3720 
3730 
3750 


S1*210/(XMAX-XMIN): S2-180/(YMAX-YMIN) 

IF S1>S2 THEN SM1-S2 ELSE SM1-S1 

DEL«.5*(210/SM1-XMAX+XMIN): XMAX-XMAX+DEL: XMIN=XMIN-DEL 
DEL* .5*(180/SM1 -YMAX+YM IN): YMAX-YMAX+DEL: YMIN-YMIN-DEL 


PLOT FROM (200,10)-(620,190) 


PX*(XMAX-XMIN)/420 
py«(YMAX-YMIN)/180 
SCREEN 2 :CLS 
FOR 11-1 TO NUMEL 
I-NCON(I1,1): J-NCON(I1,2) 

IF IOPT3-1 THEN DXI-0: DYI-0: DXJ-0: DYJ-0 ELSE 


DXI-EXAG*B(I*2-1):DYI«+EXAG*B(I*2): DXJ-EXAG*B(J*2-1):DYJ-+EXAG*B(J*2) 


3770 

3775 

3780 

3782 

3784 

3786 

3788 

3790 

3792 

3794 

3796 

3798 

3800 

3802 

3804 


IX-INT(200+(XNOD(Ij+DXI-XMIN)/PXj 
IY-INT(190-(YNOD(I)+DYI-YMIN)/PY) 


JX*INT(200+(XNOD(JHDXJ-XMIN)/PX) 

JY-INT(190-(YNOD(J)+DYJ-YMIN)/PY) 


DETERMINE IF PTS IN WINDOW 


JCASE-0 

IF IX>620 OR IX<200 OR IY>190 OR IY<10 THEN JCASE*1 
IF JX>620 OR JX<200 OR JY>190 OR JY<10 THEN JCASE-JCASE+2 


ON JCASE GOTO 3814,3814,3868 
LINE (IX,IY)-(JX,JY) 

PUT (IX-3,IY-3),NMK,OR: PUT (JX-3,JY-3),NMK,OR 
IF I0PT3-3 AND ABS(STRf11))>-EKEY(2) THEN 


>5004 ir iurio-o /mnu ado i r\v jl i j 

LINE ((IX+JX)/2-4.(IY+JY)/2-2)-((IX+JX)/2+4.(IY+JY)/2+2).1.BF 


3806 

3808 

3810 

3812 

3814 

3816 


GOTO 3868 


ONE POINT IN.. MAKE IT (IX.IY) OTHER IS (JX.JY) 


IF JCASE-1 THEN KX-IX: KY-IY: IX-JX: IY-JY: JX-KX: JY-KY 
IF IX-JX AND JY>190 THEN JY-190: GOTO 3860 ELSE 
IF IX-JX THEN JY-10: GOTO 3860 

3818 SLOPE-(JY-IY)/(JX-IX): BINT-JY-SLOPE*JX 
3820 ’ 
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3822 IF SLOPE-0 AND JX>620 THEN JX-620: GOTO 3860 ELSE 
IF SLOPE-0 THEN JX-200: GOTO 3860 
3824 * 

3826 KY-SLOPE*200+BINT 

3828 IF KY>-10 AND KY<-190 AND SLOPE>0 AND KY>JY THEN JX-200- 

SSI?00? 6 Sy-K?: SmSSl ^ KY< " 190 AN ° SL ° PE<0 AN ° KY<JY THEN 

3830 KY-SLOPE*620+BINT 

iQ/jA AN ° KY< “ 190 AND SLOPE>0 AND KY<JY THEN JX-620: 

Jxle20: JY-KY- GOTO 3860 ^ KY< " 19 ® AND SLOPE<0 AND KY>JY THEN 
3834 ’’ 

3836 KX-(190-BINT)/SLOPE 

3838 IF KX>-200 AND KX<-620 AND SLOPE>0 AND KX<JX THEN JX=KX- 

sx.fs.js? zffssr * ««»*> ««- s?«2s 

3840 KX«(10-BINT)/SLOPE 

3842 IF KX>-200 AND KX<=620 AND SLOPE>0 AND KX>JX THEN JX-KX- 

2™*5 ik SE rATA K T«R« 00 AND KX< “ 620 AN0 SLOPE<0 AND KX<JX THEN 
JX-KX: JY-10: GOTO 3860 

3844 * 

3860 LINE (IX.IY)-(JX.JY) 

3862 PUT (IX-3,IY-3),NMK.OR 

3868 NEXT II 
3870 * 

GRAPHICS MENU 


3880 

3890 

3900 

3904 

3906 

3908 

3910 

3914 

3916 

3918 


LOCATE 1,1,1: SOUND 300,3: PRINT "SELECTION - " 

LOCATE 10,2: PRINT "1..NUMBER NODES" 

LOCATE 12,2: PRINT "2..NUMBER ELEMENTS" 

LOCATE 14,2: PRINT "3..ZOOM" 

LOCATE 16,2: PRINT "<Esc>..NEXT MENU" 

X-1: Y-12: GOSUB 21010: IF IERR-1 THEN SCREEN 0: RETURN 
IF VALNEW<1 OR VALNEW>4 THEN GOTO 3900 ELSE GOPT-VALNEW 
LOCATE 1.1: PRINT " THINKING " 

3920 XX-EXAG 

3930 ON GOPT GOSUB 3970.4050,4500 
3940 IF GOPT-3 THEN GOTO 3660 ELSE GOTO 3900 
3950 RETURN 
3960 * 

3970 * NUMBER NODES 
3980 ’ 

3990 FOR 1-1 TO NUMNP 

4000 SX-200+(XNOD(I)-XMIN+XX*B(2*I-1))/PX- 
SY-190-(YNOD(I)-YMIN+XX*B(2*I))/PY 
4010 GOSUB 4170 
4020 NEXT I 
4030 RETURN 
4040 * 

4050 * NUMBER ELEMENTS 
4060 ’ 

4070 FOR 1-1 TO NUMEL 
4080 II-NCONfI,1); JJ-NC0N(I,2) 

4090 XCOORD=(XNOD(II)+XNOD(JJ)+XX*(B(2*II-1)+B(2*JJ-1 )))* 

4 00 YCOORD-(YNOD(II)+YNOD(J J)+XX*(B(2*11)+B(2*JJ)))*. 5 

4120 GOSUB 0 417 COORD_XM ^ N ^ PX: SYa190 “(YCOORD-YMIN)/PY 
4130 NEXT I 
4140 RETURN 
4150 ' 

4160 ; PUT A VALUE OF "I" AT (SX.SY) ON GRAPHICS SCREEN 

4190 FDIG=INT(I/100) >620 ^ ^ SY>19 ® ™ EN RETURN 

4200 SDIG-INT((I-FDIG*100)/10) 

4210 TDIG»INT(I-FDIG*100-SDIG*10) 

4220 IF FDIG<»0 THEN 4270 
4230 FOR II-0 TO 9 

tltl J”?! 0 -" THEN F0R j! * 0 T0 5: NDIG(J)-NUM(FDIG+1,J): NEXT J 

till PUT(SX-7,SY).NOIG.PSET 

4270 IF FDIG<-0 AND SDIG<-0 THEN GOTO 4320 

4280 FOR 11-0 TO 9 

4300 NEXT S II G “ H ^ F ° R J " 0 T ° 51 NDIG ( J )“ NUM (SDIG+1.J): NEXT J 
4310 PUT(SX.SY).NDIG.PSET 


)*.5 


JY-KY: 

JY-KY: 

JY-190: 

JY-10: 
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4320 IF FDIGc-0 AND SDIG<-0 AND TDIG<-0 THEN RETURN 
4330 FOR I1-0 TO 9 

4340 IF TDIG-II THEN FOR J-0 TO 5 : NDIG(J)-NUM(TDIG+1,J): NEXT J 
4350 NEXT II 

4360 PUT(SX+7,SY),NDIG,PSET 
4370 RETURN 
4495 * 

4500 ’ ZOOM FUNCTION 
4505 ’ 

4510 LOCATE 25,1:PRINT BLANK$;: LOCATE 25,1: PRINT "LOCATE CROSSHAIRS TO ONE 
CORNER OF ZOOM AREA AND PRESS RETURN KEY TO ENTER"; 

4520 XFIN-320:YFIN-100 

4530 IF XFIN>630 THEN XFIN-630 ELSE IF XFIN<200 THEN XFIN-200 ELSE IF 
YFIN>190 THEN YFIN-190 ELSE IF YFIN<10 THEN YFIN-10 
4540 PUT (XFIN.YFIN),MARKER 

4550 A1$-INKEY$: IF A1$="" THEN 4550 ELSE IF ASC(A1$)-27 THEN: RETURN 
ELSE IF ASC(A1$)-13 THEN GOTO 4590 ELSE A1=ASC(RIGHT$(A1$,1)) 

4560 PUT (XFIN.YFIN),MARKER 

4570 IF A1=77 THEN XFIN-XFIN+6 ELSE IF A1-75 THEN XFIN-XFIN-6 ELSE IF A1-72 
THEN YFIN-YFIN-2 ELSE IF A1-80 THEN YFIN-YFIN+2 
4580 GOTO 4530 

4590 LOCATE 25,1:PRINT BLANK$;: LOCATE 25,1: PRINT "LOCATE CROSSHAIRS TO 
OTHER CORNER OF ZOOM AREA AND PRESS RETURN KEY TO ENTER"; 

4600 XLOC1-XFIN:YLOC1-YFIN 

4610 IF XFIN>630 THEN XFIN-630 ELSE IF XFIN<0 THEN XFIN-0 ELSE IF YFIN>199 
THEN YFIN-199 ELSE IF YFIN<10 THEN YFIN-10 
4620 PUT (XFIN.YFIN),MARKER 

4630 A1$-INKEY$: IF A1$-"" THEN 4630 ELSE IF ASC(A1$)-27 THEN RETURN 
ELSE IF ASC(A1$)-13 THEN GOTO 4670 ELSE A1-ASC(RIGHT$(A1$,1)) 

4640 PUT (XFIN.YFIN),MARKER 

4650 IF A1-77 THEN XFIN-XFIN+6 ELSE IF A1-75 THEN XFIN-XFIN-6 ELSE IF A1-72 
THEN YFIN-YFIN-2 ELSE IF A1-80 THEN YFIN-YFIN+2 
4660 GOTO 4610 

4670 REM ** COMPUTE NEW SCALE FOR DWG. ** 

4680 IF (XLOC1-XFIN)-0 OR (YLOC1-YFIN)=0 THEN 

MSG$-"ZOOM POINTS IN HORIZONTAL OR VERTICAL LINE": GOSUB 26000:RETURN 
4690 IF XLOC1<XFIN THEN XMAX«XMIN+PX*(XFIN-200): XMIN=XMIN+PX*(XLOC1-200) 
ELSE XMAX-XMIN+PX*(XLOC1-200): XMIN-XMIN+PX*(XFIN-200) 

4700 IF YLOC1<YFIN THEN YMAX-YMIN+PY*(190-YLOC1): YMIN=YMIN+PY*(190-YFIN) 
ELSE YMAX-YMIN+PY*(190-YFIN): YMIN-YMIN+PY*(190-YLOC1) 

4710 RETURN 
5600 * 

5610 1 GET/SAVE/DELETE DATA FILES 
5620 ' 

5630 IMENU-4: GOSUB 25000: I0PT5-ISEL 
5640 IF IRETO0 THEN RETURN 
5650 GOSUB 26400 
5660 GOSUB 23000 

5670 IF IERR-53 AND IOPT5-2 THEN GOTO 5680 ELSE IF IERRO0 THEN GOTO 5630 
5680 LOCATE 24,10 

5690 IF I0PT5-1 THEN PRINT "ENTER FILE TO GET ";: ELSE IF IOPT5-2 THEN 
PRINT "ENTER FILE TO SAVE";: ELSE PRINT "ENTER FILE TO DELETE"; 

5700 X-24: Y-33: GOSUB 21000 

5710 IF IERRO0 THEN GOTO 5630 
5720 NAM$»INPT$ 

5730 ON I0PT5 GOSUB 5760,5940,6110 

5740 GOTO 5630 
5750 * 

5760 • LOAD AN EXISTING MESH 
5770 • 

5780 NAM$=DV$+NAM$: OPEN NAM$ FOR INPUT AS 3 

5790 INPUT #3,TITLES 

5800 INPUT #3,NUMEL,NUMNP,NMAT,NLOAD 

5810 INPUT #3,EKEY(1),EKEY(2),EKEY(3),EKEY(4),EKEY(5) 

5820 FOR 1-1 TO NUMNP 

5830 INPUT #3,K,XN0D(K),YN0D(K) 

5840 NEXT I 

5850 FOR 1-1 TO NUMEL 

5860 INPUT #3, J,NCON(J,1),NC0N(J,2),AR(J) 

5870 NEXT I 

5880 FOR 1-1 TO NLOAD 

5890 INPUT #3, ILOAD(1,1),I LOAD(1,2),RLOAD(I) 

5900 NEXT I 

5910 CLOSE #3: RETURN 

5920 REM ** END MODULE TO RELOAD MATERIAL/LOAD DATA ** 

5930 * 


( continued ) 
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5940 

5950 

5960 

5970 

5980 

5990 

6000 

6010 

6020 

6030 

6040 

6050 

6060 

6070 

6080 

6090 

6100 

6110 

6120 

6130 

6140 

6150 

6160 

6170 


# SAVE MODEL DATA 

t 

NAM$-DV$+NAM$: OPEN NAM$ FOR OUTPUT AS 3 
WRITE #3.TITLES 

WRITE #3.NUMEL,NUMNP,NMAT,NLOAD 
WRITE #3.EKEY(1),EKEY(2).EKEY(3).EKEY(4).EKEY(5) 
FOR 1-1 TO NUMNP 
WRITE #3,I.XN0D(I).YN0D(I) 

NEXT I 

FOR 1-1 TO NUMEL 

WRITE #3. I.NCON(I,1),NCON(I.2),AR(I) 

NEXT I 

FOR 1-1 TO NLOAD 

WRITE #3. ILOAD(I,1),ILOAD(I,2),RLOAD(I) 

NEXT I v ' 

CLOSE #3:RETURN 

» 

’ DELETE A FILE 


CLS: SOUND 500,4 
LOCATE 5,30: PRINT 


***** WARNING ***»*" 


LOCATE 5,10: PRINT "A DELETED FILE CAN NOT BE RECOVERED ... TO DELETE" 
LOCATE 7,10: PRINT “ - 


. - - PRESS .. Y .. ELSE ANY OTHER KEY TO ABORT"' 

„ A1$—INKEY$: IF A1$-"" THEN 6170 ELSE IF A1$="Y" OR A1$-"y" THEN 
KILL DV$+NAM$: RETURN ELSE RETURN y 

10000 * 

10010 * ANALYSIS 
10020 
10070 
10074 
10078 
IERR-1 
10082 
10086 


IERR-0: CLS: LOCATE 2,30: PRINT "CHECKING DATA": PRINT 
FOR 1-1 TO NUMEL 

IF NCON(I,1)-NCON(I,2) THEN PRINT "ELEMENT "+STR$(I)+" NODE ERROR": 

IF AR(I)<-0 THEN PRINT "ELEMENT "+STR$(I)+" AREA ERROR": IERR-1 
" NODE NOT DEFINED ;1 ? > IERR-1° R NCON(I ' 1)<m0 THEN PRINT "ELEMENT " + STR$(I) + 

" 0 NODE NOT F DEFINED" 2 hlERS-i° R NCON(I>2)< “ 0 THEN PRINT "ELEMENT "+STR$(I) + 
NEXT I 

LOCATE 25,10: PRINT "PRESS ANY KEY TO CONTINUE": 

A1$«INKEY$: IF A1$-"" THEN 10094 
IF IERRO0 OR ASC(A1$)-27 THEN IERR-0: RETURN 
GOSUB 30000 

IF BW>MBW THEN MSG$-"BANDWIDTH EXCEEDS ALLOWABLE":GOSUB 26000- RETURN 
NDF NUMNP > 2 AXNP THEN MSG *“" T0 ° MANY nodes " : GOSUB 26000: RETURN 
FOR I1-1 TO NDF 
FOR JJ-1 TO BW 
A(11,JJ)=0: B(11)=0 
NEXT JJ 
NEXT II 


10088 

10090 

10094 

10096 

10100 

10102 

10105 

10107 

10108 
10110 
10120 
10130 
10140 
10150 
10160 
10170 
10180 
10190 
10200 
10210 
10220 
10230 
10240 
10250 
10260 


; COMPUTE ELEMENT STIFFNESS/ADD TO GLOBAL 

FOR IELE-1 TO NUMEL 
GOSUB 10700 
NEXT IELE 

’ IMPOSE LOADS/FIXITIES 


CP-10'12 

FOR 1-1 TO NLOAD 

26000 RETURN 10 ^*’ 1 >NUMNP ™ EN MSG *“" ERR0R IN LOAD"+STR$(I) : GOSUB 
B(J)-RLOAD(I) OAD(I ' 2) ’ 0 ° R IL0AD (I,2)=1 ™ EN j -2*IL0AD(I,1)-1+IL0AD(I,2): 

10280 IF ILOAD(I.2)-2 OR ILOAD (I,2)-3 THEN J«2*ILOAD(I,1)-3+IL0AD(I,2)• 
A(J.1)-A(J,1)*CP: B(J)=RLOAD(I)*A(J,1) J ' * ' 

10290 NEXT I 


10300 

10310 

10320 

10330 

10340 

10350 

10360 

10370 


’ SOLVE MATRIX 

FOR N-1 TO NDF 
FOR L-2 TO BW 

IF A(N,L)=0 THEN GOTO 10450 
I-N+L-1 

C=A(N,L)/A(N,1) 


226 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 






J uly 


10380 J-0 

10390 FOR K-L TO BW 

10400 J-J+1 

10410 A(I,J)-A(I,J)-C*A(N,K) 

10420 NEXT K 

10430 A(N,L)»C 

10440 B(I)«B(I)-A(N,L)*B(N) 

10450 NEXT L 

10460 B(N)«B(N)/A(N,1) 

10470 NEXT N 

10480 REM ** BACK SUBSTITUTION ** 

10490 FOR M-2 TO NDF 

10500 N-NDF+1-M 

10510 FOR L-2 TO BW 

10520 IF A(N,L)«0 THEN GOTO 10550 

10530 K-N+L-1 

10540 B(N)«B(N)-A(N,L)*B(K) 

10550 NEXT L 
10560 NEXT M 
10570 • 

10580 * CALCULATE STRESSES 
10590 * 

10600 IF NUMNPc-0 THEN RETURN 
10610 FOR IELE-1 TO NUMEL 
10620 NN1«NCON(IELE,1) 

10630 NN2«NC0N(IELE,2) 

10640 X«XNOD(NN2)-XNOD(NN1) 

10650 Y«YNOD(NN2)-YNOD(NN1) 

10660 E«EKEY(1)/(X~2+Y~2) 

10670 STR(IELE;-E*(X*(B(2*NN2-1)-B(2*NN1-1))+Y*(B(2*NN2)-B(2*NN1))) 

10680 NEXT IELE 
10690 RETURN 
10700 * 

10710 * ELEMENT STIFFNESS... ELEMENT # IELE 
10720 • 

10730 NN1-NCON(IELE,1 ) 

10740 NN2«NCON(IELE,2) 

10750 X-XNOD(NN2)-XNOD(NN1) 

10760 Y-YNOD(NN2)-YNOD(NN1) 

10770 AEL«AR(IELE)*EKEY(1)/(SQR(X A 2+Y^2))^3 


10780 

XXYY( 4 

l)-x 

10790 

xxyy(: 

>)-x 

10800 

XXYY(: 

5)—Y 

10810 

XXYYO 

O-v 


10820 FOR 1= 1 TO 4 

10830 FOR J-1 TO 4 

10840 BK(I,J)-AEL*XXYY(I)*XXYY(J) 

10850 NEXT J 

10860 NEXT I 

10870 FOR 11-1 TO 2 

10880 FOR 12-1 TO 2 

10890 FOR J1-1 TO 2 

10900 FOR J2-1 TO 2 

10910 JJ«2*NCON(IELE,J2)-2+J1 

10920 II«2*NCON(IELE > I2)-1+I1-JJ 

10930 IF II>0 THEN 

I«2*(I1-1)+I2: J-2^(J1-1)+J2: 

A( JJ,11)-A(JJ,11)+BK(I,J) 

10940 NEXT J2 

10950 NEXT J1 

10960 NEXT 12 
10970 NEXT II 
10980 RETURN 
20000 # 

20010 • ROUTINE: SCREEN RESET AND CW NOTICE 
20020 • 

20030 KEY OFF 

20040 FOR 1-1 TO 10: KEY I # MM : NEXT I 

20050 FOR J-0 TO 3: SCREEN 0,0,J,0: CLS: NEXT J 

20060 • 

20070 • PRINT COPYRIGHT NOTICE 
20080 • 

20090 SCREEN 0,0,0,1 

20100 FOR 1-5 TO 70 STEP 5: LOCATE 6,1: PRINT "- H ; : LOCATE 20,1: 

PRINT n - M ; : NEXT I 
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LOCATE 

LOCATE 


20110 
20120 
1984" 

20130 
20140 
20150 
20160 
20170 
20180 
21000 
21010 
21020 
21030 
21040 
21050 
21060 
21070 
21080 A1$« HM 
21090 IERR-0 


9,36: 

11,15: 


PRINT 

PRINT 


"TRUSS2"; 
"REVISION 


1.00 


COPYRIGHT 


C.S. PEDICINI 


COLOR 0,15 
LOCATE 16,25,0 
COLOR 7,0 
SCREEN 0,0,0,0 
A1$-INKEY$: IF 
RETURN 


PRINT " PRESS ANY KEY TO CONTINUE " 


A1$- 


THEN 20170 


STRING INPUT MODULE 

X,Y ... CURSOR LOCATION TO PRINT STRING 
A1$ ... MAY CONTAIN FIRST CHARACTER 
IERR... 1 FOR ABORT 
VALNEW. NUMERIC RESULT 
INPT$...STRING RESULT 


21100 
21110 
21120 
21130 
21140 
LOCATE 
21150 
21160 
21170 
21180 
21190 
21200 
21210 
21220 
21230 
22000 
22010 
22020 
22030 
22040 
22080 MSG$«"" 


INPT$=A1$: IF LEN(A1$)=0 THEN GOTO 21120 
IF ASC(A1$)-13 THEN 21190 
IF ASC(A1$)-27 THEN IERR-1: RETURN 
LOCATE X,Y: PRINT INPT$; 

A1$*INKEY$:IF A1$«"" THEN 21130 

IF ASC(A1$)-8 AND LEN(INPT$)>=1 THEN INPT$-MID$(INPT$,1,LEN(INPT$)-1) 
X A Y: PRINT INPT$;" GOTO 21130 V J J 

:RETURN 


IF ASC(A1$)-27 THEN IERR=1 
IF ASC(A1$)-13 THEN 21190 
INPT$«INPT$+A1$:LOCATE X,Y: 

CONVERT VALUE 

VALNEW-VAL(INPT$) 

RETURN 


ERROR TRAP MODULE 

ERR . BASIC ERROR CODE 

MSG$ . ERROR TEXT 


PRINT INPT$;: GOTO 21130 


22090 

22100 

22110 

22120 

22130 

22140 

22150 

22160 

22170 

22180 

22190 

22200 

22210 

22220 

22230 

22240 

23000 

23010 

23020 

23030 

23040 

23050 

23060 

23070 

23090 

23100 

23110 

23120 

23130 

23135 

23137 

23140 

23150 

23160 

23170 

23180 


IF ERR-24 OR ERR-25 OR ERR-27 THEN MSG$*"PRINTER ERROR" 
IF ERR-53 THEN MSG$-"FILE DOES NOT EXIST" 

IF ERR-57 THEN MSG$»"DOS ERROR ON DISKETTE I/O" 

"DISK FULL" 

"INPUT PAST END OF FILE" 

"BAD FILE NAME" 

"DISK WRITE PROTECTED" 

"DISK NOT READY" 


IF ERR-61 THEN MSG$ 
IF ERR-62 THEN MSG$ 
IF ERR=64 THEN MSG$ 
IF ERR-70 THEN MSG$ 
IF ERR-71 THEN MSG$ 


IF ERR-72 THEN MSG$«"DISK MEDIA ERROR" 

IF MSG$-"" THEN MSG$*"ERROR CODE "+STR$(ERR) 


* PRINT ERROR MSG 

IERR-ERR: SCREEN 0.0,1,1: 
RESUME 22240 
RETURN 


GOSUB 26000: SCREEN 0.0.0,0 


' DETERMINES DIRECTORY FOR PATH DV$ USING SCREENS 0,2 AND 3 
’ FILE LIST IS IN LINES 3-22..LINE 24 IS COMMAND LINE 

• DV$. DIRECTORY/PATHNAME 

’ NUMFIL.. NUMBER OF FILES 

’ I.J.K... USED AS INDICES 

* X.Y. LOCATION OF FILE FOR SCREEN 0 

l 

CLS: NAM$="": IERR=0: SCREEN 0,0,2,2: CLS 

LOCATE 12,35: COLOR 0,15: PRINT "SORTING":COLOR 7,0 

I 

’ XFER FILES FROM SCREEN 3 TO SCREEN 1... FIND # OF FILES 


’ INTERPRETIVE MODE 
• COMPILED MODE 
NUMFIL=0 


11-2: 12-18: 13=17: 14=13-11: 15-4 
’11-1: 12-13: 13-12: 14=13-11: 15=6 
SCREEN 0,0,3,2: CLS: FILES DV$+"*.*• I 
FOR 1=11 TO 24 
FOR J-1 TO 15 
SCREEN 0.0,3,2 

IF SCREEN(I,I2*J-I3)=32 OR SCREEN(I,I2*J-I3)=0 THEN GOTO 23260 
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23190 A1$»"" 

23200 FOR K—13 TO -14 

23210 A1$«A1$+CHR$(SCREEN(I,I2*J+K)) 

23220 NEXT K 

23230 NUMFIL-NUMFIL+1 

23240 X=15*INT(NUMFIL/20)+1: Y«NUMFIL-INT(X/15)*19+2 

23250 SCREEN 0,0,0,2: LOCATE Y,X: PRINT A1$ 

23260 NEXT J 
23270 NEXT I 
23280 SCREEN 0,0,0 

23290 LOCATE 1,30: PRINT " DRIVE CODE - ";DV$ 

23300 RETURN 
23310 • 

23320 0 ERROR TRAP 
23330 * 

23340 GOSUB 22000 

23350 IF ERR-53 THEN RESUME 23280 

23360 GOSUB 26000: IERR-1 

23370 RETURN 

24000 • 

24010 * TRANSFER CONTROL 
24020 • 

24030 CLS 

24040 CLS: SOUND 400,2: LOCATE 6,30 

24050 PRINT " ***** WARNING ***♦*":LOCATE 7,20 

24060 PRINT " BEFORE YOU EXIT THIS PROGRAM MAKE SURE YOU":LOCATE 8,23 

24070 PRINT M HAVE SAVED ALL OF YOUR DATA FILE(S) " 

24080 LOCATE 13,30: PRINT "ARE YOU SURE Y-YES" 

24090 A1$-INKEY$:IF A1$- M " THEN 24090 ELSE IF A1$-"y" OR A1$="Y" THEN SYSTEM 
24100 RETURN 
25000 ’ 

25010 • MENU PRINT/ENTRY 

25020 * MENU$(10,6)... 10 MENUS, 6 ITEMS PER MENU 


25030 1 IMENU.MENU TO BE PRINTED 

25040 * ISEL. ITEM SELECTED FROM MENU 

25050 * IRET. <>0 IF ABORTED 

25060 * 

25070 CLS 


25080 LOCATE 1,(80-LEN(TITLE$))/2: PRINT TITLES 
25090 LOCATE 1,70: PRINT DAT1$ 

25100 LOCATE 4,30: PRINT MENU$(IMENU,1) 

25110 • 

25120 OPTMAX-0 
25130 FOR 1-2 TO 7 

25140 IF MENU$(IMENU,I)-"" THEN 25170 

25150 OPTMAX-OPTMAX+1 

25160 LOCATE 2*1+3,27: PRINT 1-1; M M ;MENUS(IMENU,I) 

25170 NEXT I 
25180 0 

25190 0 ACCEPT OPTION 
25200 ‘ 

25210 LOCATE 25,60: PRINT "ESC - MAIN MENU"; 

25220 IRET-0 

25230 LOCATE 22,30: COLOR 0,15: PRINT "SELECTION - "; :COLOR 7,0 
25240 X-22: Y-43: GOSUB 21000 

25250 IF IERR-1 THEN IRET-1: RETURN 

25260 IF VAL(INPT$)<>0 AND VAL(INPT$)<-OPTMAX THEN ISEL=VAL(INPT$): RETURN 
25270 MSGS-"INVALID MENU RESPONCE ": SCREEN 0,0,1,1: GOSUB 26000: 

SCREEN 0,0,0,0: INPT$-"": LOCATE 22,42: PRINT " ":GOTO 25240 

26000 0 

26010 0 ERROR SUBROUTINE 

26020 0 MSGS... CONTAINS ERROR MESSAGE 

26030 0 

26040 CLS: SOUND 600,6 
26050 LN-LEN(MSGS) 

26060 LOCATE 7,32: PRINT "PROBLEM" 

26070 LOCATE 10,INT((80-LN)/2): PRINT MSG$ 

26080 LOCATE 15,27: PRINT "PRESS ANY KEY TO CONTINUE"; 

26090 AlS-INKEYS: IF A1$»"" THEN 26090 ELSE RETURN 
26100 0 
26400 0 

26410 0 CURRENT DIRECTORY/PaTH 
26420 0 
26430 CLS 

26440 LOCATE 12,10 

26450 PRINT "CURRENT DIRECTORY: ";: COLOR 0,7: PRINT " ";DV$;" ":COLOR 7,0 
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26460 LOCATE 14,10 

26470 PRINT "NEW DIRECTORY:" 

26472 LOCATE 20,10: PRINT " TO CHANGE DIRECTORIES/DRIVES ENTER THE NAME OF " 

26474 LOCATE 21,10: PRINT " THE NEW DRIVE AND PRESS THE RETURN KEY. TO 

RETAIN 

26476 LOCATE 22,10: PRINT " THE CURRENT ONE PRESS THE RETURN KEY." 

26478 LOCATE 14,25,1 

26480 A1$-INKEY$: IF A1$-"" THEN 26480 ELSE IF ASC(A1$)-13 THEN RETURN 
26490 X-14: Y-25: COLOR 0,7: GOSUB 21090: COLOR 7.0 

26500 IF IERRO0 THEN RETURN 

26510 IF RIGHT$(INPT$,1)-":" THEN DV$-INPT$: RETURN 

26520 MSG$-"INVALID DRIVE SPECIFICATION": GOSUB 26000: GOTO 26400 

30000 * 

30010 ’ DTERMINE BANDWIDTH . REF SEGERLIND PG 18 

30020 * NCON(I.J)... ELEMENT NUMBERS 

30030 * MDIFF. MAX NODE DIFFERENCE IN AN ELEMENT 

30040 ' NUMEL.NUMBER OF ELEMENTS 

30050 ’ BW. BANDWIDTH 

30060 ’ 

30070 MDIFF-0: CLS: LOCATE 12,35: PRINT "WORKING" 

30080 FOR 1-1 TO NUMEL 

30090 DIFF«ABS(NCON(I,1)-NCON(I,2)): IF DIFF>MDIFF THEN MDIFF-DIFF 

30100 NEXT I 

30110 BW-2*(MDIFF+1) 

30120 RETURN 
30130 * 

31000 * 

31010 ' ROUTINE TO PRINT TO SCREEN OR LINEPRINTER 

31020 ' PRNT$(5). ARRAY OF Y/N PRINT CHOICES 

31030 * 

31040 CLS: LOCATE 1,28: PRINT "PRINTER CONTROL VARIABLES" 

31050 LOCATE 5,28: PRINT "ENTER TO PRINT TO SCREEN" 

31060 LOCATE 7,28: PRINT "ENTER TO PRINT LINEPRINTER" 

31070 COLOR 0,15: LOCATE 5,34: PRINT “ S “: LOCATE 7,34: PRINT " L ": 

COLOR 7,0 

31080 LOCATE 13,30: PRINT "ENTRY -": X-13: Y-38: GOSUB 21000 
31090 IF INPT$="S“ OR INPT$-"8" THEN INPT$-"S": GOTO 31120 ELSE 
IF INPT$-"L“ OR INPT$-“I" THEN INPT$»"L“: GOTO 31120 
31100 RETURN 
31110 * 

31120 * ESTABLISH PRINT OPTIONS 
31130 ' 

31140 X-5: Y-28 

31150 PRNT$(1)-"Y": FOR 1-2 TO 5: PRNT$(I)-PRNT$(1): NEXT I 

31160 CLS 

31170 LOCATE 17,5: PRINT " USE UP/DOWN ARROWS TO POSITION CURSOR AND ENTER " 

31180 LOCATE 18,5: PRINT “ Y/N ..CAPITALS ONLY!.. USE F10 TO CONTINUE" 

31190 LOCATE 20,5: PRINT “ <Esc> RETURNS TO MENU" 


31200 LOCATE 3.1: PRINT " PRINT Y/N" 

31210 LOCATE 5.1: PRINT "NODE POINT DATA. ";PRNT$(1) 

31220 LOCATE 7.1: PRINT "ELEMENT DATA. ";PRNT$(2) 

31230 LOCATE 9,1: PRINT "LOAD AND MATERIAL DATA- ";PRNT$(3) 

31240 LOCATE 11,1:PRINT "STRESS/STRAIN RESULTS. ";PRNT$(4) 

31250 LOCATE 13,1:PRINT "NODE DISPLACEMENTS. ";PRNT$(5) 

31260 ’ 

31270 • TRAP KEYS 
31280 ' 

31290 LOCATE X,Y,1 


31300 A1$-INKEY$: IF A1$- M " THEN 31300 ELSE IF ASC(A1$)=27 THEN RETURN 
31310 IF LEN(A1$)<>2 THEN IF A1$-"Y" OR A1$-"N" THEN LOCATE X.Y.1: 

PRINT A1$: PRNT$(INT(X/2-1.5))-A1$: GOTO 31290 ELSE GOTO 31290 
31320 A1»ASC(RIGHT$(A1$,1)) 

31330 IF A1-72 AND X>-7 THEN X-CSRLIN-2 

31340 IF A1=80 AND X<13 THEN X-CSRLIN+2 

31350 IF A1<>68 THEN 31290 
31360 ’ 

31370 * PRINT DATA 
31380 * 

31382 GOSUB 31390: CLOSE #1: RETURN ’ STANDARD ESCAPE 

31390 IF INPT$-"S" THEN OPEN "SCRN:" FOR OUTPUT AS #1: GOTO 31470 
31400 OPEN "LPT1:" FOR OUTPUT AS #1 

31410 CLS: LOCATE 10,10: PRINT "SET UP PRINTER AND PRESS ANY KEY WHEN READY 

II 

31420 A1$-INKEY$ : IF A1$="" THEN 31420 ELSE IF ASC(A1$)-27 THEN RETURN 
31430 CLS: LOCATE 13,30:PRINT "PRINTING DATA"; 

31440 LOCATE 16,20: PRINT "TO STOP PRINTING PRESS ESC KEY" 

31450 PRINT #1,CHR$(27)"N"CHR$(6) 
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31460 ’ 

31470 * OUTPUT NODE DATA 
31480 * 

31490 IF PRNT$(1)<>"Y" THEN 31610 
31530 FOR 1-1 TO NUMNP 

31540 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN 

31545 IF 1=1 OR CSRLIN=23 THEN GOSUB 32190: 

PRINT #1, TAB(10);"NODE X-COORD Y-COORD";CHR$(10);CHR$(10) 

31550 PRINT #1. TAB(10); 

31560 PRINT #1, USING " ### ":I; 

31570 PRINT #1. USING - ###.#####";XNOD(I),YNOD(I) 

31590 NEXT I 

31600 * 

31610 * LIST ELEMENTS 
31620 ’ 

31630 IF PRNT$(2)<>"Y" THEN 31760 
31680 FOR 1=1 TO NUMEL 

31690 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN 

31695 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190: 

PRINT #1, TAB(10);" ELEM NODE NODE SECTION": 

PRINT #1, TAB(10);" NO. I J AREA" ,CHR$( 10) 

31700 PRINT #1, TAB(10); 

31710 PRINT #1, USING “ ### ";I,NCON(I,1),NCON(I,2); 

31720 PRINT #1. USING "###.###";AR(I) 

31740 NEXT I 

31750 * 

31760 * LIST LOADS 
31770 * 

31780 IF PRNT$(3)o"Y" THEN 31890 
31820 FOR 1=1 TO NLOAD 

31830 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN 

31835 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190: 

PRINT #1. TAB(10);"NODE NO. CODE VALUE".CHR$(10),CHR$(10) 

31840 PRINT #1, TAB(10); 

31850 PRINT #1, USING " ### ";ILOAD(I.1).ILOAD(I.2); 

31860 PRINT #1, USING " #.##" A "*";RLOAD(I) 

31870 NEXT I 

31880 * 

31890 * OUTPUT RESULTS 
31900 * 

31910 IF PRNT$(4)<>“Y" THEN 32020 
31950 FOR 1=1 TO NUMNP 

31960 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN 

31965 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190: 

PRINT #1. TAB(10);"NODE NO X-DISP. Y-DISP. ",CHR$(10),CHR$(10) 

31970 PRINT #1, TAB(10): 

31980 PRINT #1, USING " ### ";I; 

31990 PRINT #1. USING " ###.#####";B(2*I-1),B(2*I) 

32000 NEXT I 

32010 ’ 

32020 ' OUTPUT RESULTS 
32030 * 

32040 IF PRNT$(5)o"Y" THEN 32170 
32080 FOR 1=1 TO NUMEL 

32090 A1$=INKEY$: IF A1$=CHR$(27) THEN RETURN 

32095 IF 1=1 OR CSRLIN-23 THEN GOSUB 32190: 

PRINT #1, TAB(10);"ELEM NO STRESS-PSI FORCE-LBS",CHR$(10),CHR$(10) 

32100 PRINT #1, TAB(10); 

32110 PRINT #1. USING “ ### ";I; 

32120 PRINT #1. USING " #######.";STR(I),STR(I)/AR(I) 

32130 NEXT I 

32140 IF INPT$o"S“ THEN CLOSE #1: RETURN 

32150 LOCATE 25,5: PRINT "PRESS ANY KEY TO CONTINUE"; 

32160 A1$=INKEY$: IF A1$="" THEN 32160 ELSE RETURN 
32170 CLOSE #1: RETURN 
32180 * 

32190 * PAGE HEADER 
32200 ’ 

32210 IF INPT$<>"S" THEN X=5: WHILE X: LPRINT CHR$(10): X-X-1: WEND: GOTO 
32240 

32220 LOCATE 25,5: PRINT "PRESS ANY KEY TO CONTINUE"; 

32230 A1$=INKEY$: IF A1$=“" THEN 32230 ELSE CLS 

32240 PRINT #1. CHR$(10) 

32250 PRINT #1. SPC(1);DAT1$ 

32260 PRINT #1. TAB(40-LEN(TITLE$)/2); TITLE$ 

32270 PRINT #1, CHR$(10) 

32280 RETURN 
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ughbug.asm 

"An 8031 In-CIrcult Emulator," by George Dinwiddle. July, 
page 181. 


TITLE • UGHBUG VERSION 1.00 12 January 1986 * 

SBTTL * Copyright 1986 by George Dinwiddie * 

PGLEN 55 


NOTICE : This monitor program may be copied and distributed on the 
condition that all copyright notices and this notice remain intact. 
This program is provided without any warranty or assumption of 
liability whatsoever. If It doesn’t work or it breaks something, I’m 
sorry, but It’s not my problem. 

On the positive side, if this program helps you, I am glad to be of 
assistance. I ask only two favors. First, if you fix any bugs or 
add any enhancements, please send me a copy. (CP/M 8" SSSD or IBM-PC 
5.25" are best for me.) Secondly, If you use this program to help 
develop a commercial product, please remember me. As a suggestion, a 
$50.00 donation would be a bargain for you and welcome by me. If you 
would prefer, either a sample of your product or a donation more in 
line with the profits on your product would be ok, too. If you use 
this program on a home project, I understand that you can’t alway 
afford to pay for the value of good software. My own CP/M computer 
would be worthless without the wonderful public domain software that 
I have received for free. If you want to send me your favorite 
public domain goody, great. In any event, you are welcome to this — 
enjoy, enjoy. 

George Dinwiddie 
10965 Trotting Ridge Way 
Columbia, MD 21044 

REVISION HISTORY : 

Version 1.00 George Dinwiddie 12 January 1986. 

First public release. Fixed GO-from-break bug. 

Version 0.16 George Dinwiddie 26 January 1984 
Added JUMPTABLE and HEXMATH functions. 

WISH LIST : 

Load command (*L') to load ram from a hex file through the terminal 
port. 

Find command ('F’) to search for sequences specified in hex or 
ascii. I always Intended to add this one but never did. That's 
the reason the Insert command isn’t a Fill command. 

Disassemble command (maybe 'Ll’ for Unassemble). 

Single-line assembler. It’s amazing how good you get at hand 
assembly when you practice. Still, It would be nice to have this. 


MOTE : Some labels are of the following form : 
IF000 == IF 

THN000 « THEN 
ELS000 »« ELSE 
NDI000 «= ENDIF 


MONBASE 

EQU 

APPBASE 

EQU 

RAMBASE 

EQU 

UARTBASE 

EQU 

UARTDATA 

EQU 

UARTCONT 

EQU 

RAMEND 

EQU 

BYTENUM 

EQU 

STACK 

EQU 


0000H ;4K MONITOR 

2000H ;8K APPLICATION EPROM 

4000H ;8K RAM 

7800H ;TERMINAL (uart) LOCATION 
UARTBASE ; C/D* * A0 
(UARTBASE+1) 

5FFFH ;END OF EXTERNAL RAMSPACE 
(RAMEND-8) ;FROM HERE ON USED BY BREAK ROUTINE 
50H ;stack begins here 
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PCON 


87H 


AVOCET ASSEMBLER DOESN’T KNOW PCON 


J uly 


EQU 


;reserved Internal ram locations 

RESERVED EQU 48H ;reserved internal ram 

HIBYTE EQU RESERVED ;TOP OF 16-BIT ADDRESS 

LOBYTE EQU RESERVED*1 ;BOTTOM OF 16 BIT ADDRESS 

FIRST EQU RESERVED+2 ;START ADDRESS HIGH (LOW IN RESERVED+3) 

LAST EQU RESERVED+4 ;END ADDRESS HIGH (LOW IN RESERVED+5) 

TO EQU RESERVED+6 ;TO ADDRESS HIGH (LOW IN RESERVED+7) 


; reserved 

register bank 

(and aliases for those registers) 

RESBANK 

EQU 

1 

jregister bank 1 

< 

REG0 

EQU 

8*RESBANi 

REG1 

EQU 

REG0+1 

;sometimes you can’t use R1 

REG2 

EQU 

REG0+2 

REG3 

EQU 

REG0+3 


REG4 

EQU 

REG0+4 


REG5 

EQU 

REG0+5 


REG6 

EQU 

REG0+6 


REG7 

EQU 

REG0+7 


•.character 

equates 



CR 

EQU 

0DH 

CARRIAGE RETURN 

LF 

EQU 

0AH 

LINE FEED 

SPACE 

EQU 

20H 

SPACE CHARACTER 

TAB 

EQU 

09H 

TAB CHARACTER 

DOT 

EQU 

2EH 

PERIOD 

BACKSP 

EQU 

08H 

BACKSPACE 

EOT 

EQU 

04H 

end of text 


;*********************************************************** 

ORG MONBASE 

START: JMP UGHBUG 


ORG START+03H 

LJMP RAMBASE+03H 

ORG START+0BH 

LJMP RAMBASE+0BH 

ORG START+13H 

LJMP RAMBASE+13H 

ORG START+1BH 

LJMP RAMBASE+1BH 

ORG START+23H 

LJMP RAMBASE+23H 


;INTERRUPT VECTORS JUMP TO RAM 


;*********************************** 


LJMPTBL: 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 

LJMP 


LJMP COOL 
WARM 

IN 

INCH 

INHEX 

BYTES 

BADDR 

THRADR 

OUT 

OUTCH 

OUTS 

OUT2S 

CRLF 

OUT2H 

OUTR0 

OUTC2HS 

PDATA 


LJMP INCI 6 

LJMP DEC16 

LJMP CPY 

LJMP BRKPT 

PAGE 

MSIGNON: 

DB CR, LF, ’Ughbug MCS-51 monitor, version 1.00* 


( continued) 
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DB CR, LF. 'copyright 1986 by George Dinwiddie.', LF, 04H 

********************************************************* 


UGHBUG: MOV 
MOV 
SETB 
CLR 
CLR 
MOV 
MOV 
MOVX 


CLEAR: 


SP.#STACK 
STACK.SP 
RS0 
RSI 
A 

DPTR.#BYTENUM 
R0,#(RAMEND-BYTENUM+1) 


;store stack pointer for cool start 
;SELECT REGISTER BANK 1 


©DPTR.A 


;clear space used by break routine 



INC 

DPTR 



DJNZ 

R0.CLEAR 


DLAY: 

DJNZ 

ACC.DLAY 

WAIT HERE FOR UART TO WAKE-UP 


DJNZ 

R0.DLAY 



MOV 

DPTR,#UARTCONT 

INIT UART 


CLR 

A 



MOVX 

©DPTR.A ; 

send three zeros because you don't know 


NOP 

i 

In what crazy mode the ugh-art wakes up 


DJNZ 

ACC,$-1 



MOVX 

©DPTR.A 



NOP 




DJNZ 

ACC,$-1 



MOVX 

©DPTR.A 



NOP 




DJNZ 

ACC,$-1 



MOV 

A.#40H 

software reset uart 


MOVX 

@DPTR,A 



CLR 

A 

many thanks to Ernest Penzenstad1er 


NOP 

;for taming the Infamous 8251A ugh-artl 


DJNZ 

ACC,$-1 



MOV 

A,#01001110B 

MODE 


MOVX 

©DPTR.A 



MOVX 

A,©DPTR 

GET STATUS 


JNB 

ACC.0,$-1 

WAIT FOR TXRDY 


MOV 

A,#00110111B 

COMMAND 


MOVX 

©DPTR.A 



MOV 

DPTR.fMSIGNON 



CALL 

PDATA 


COOL: 

MOV 

SP.STACK 


; ************************************************************* 

WARM: 





MOV 

DPTR,#MPROMPT 

;WARM START 


CALL 

PDATA 



CALL 

INCH 



JNB 

ACC.6.$+5 

JUMP IF NOT A LETTER 


CLR 

ACC. 5 

CONVERT LOWER TO UPPER CASE 


MOV 

R7.A 

SAVE CHARACTER INPUT 


MOV 

DPTR.#FUNTAB 

POINT TO FUNCTION TABLE 

SCAN: 

CLR 

A 



MOVC 

A,@A+DPTR 



JZ 

WARM 

;END OF TABLE 


CJNE 

A.0FH.NEXT 

;COMPARE WITH SAVED CHARACTER 


MOV 

A.#01H 



MOVC 

A,©A+DPTR 

;GET HIGH BYTE OF JUMP 


MOV 

R2.A 

;SAVE IN R2 


MOV 

A,#02H 



MOVC 

A,@A+DPTR 

;GET LOW BYTE OF JUMP 


MOV 

R3.A 

;SAVE IN R3 


PUSH 

REG3 

-.PUSH R3 (LOW BYTE) 


PUSH 

REG2 

;PUSH R2 (HIGH BYTE) 


RET 


;POP & JUMP 

NEXT: 

INC 

DPTR 



INC 

DPTR 



INC 

DPTR 



JMP 

SCAN 



PAGE 



;************************************************************* 

HELP: 





MOV 

DPTR.#MHELP 



CALL 

PDATA 



JMP 

WARM 
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J uly 


DUMP: 

DMP1: 
DMP3: 

DMP4: 

DMP5: 

NEWLIN: 

SPACES: 

MORE: 

MOREC: 

ENDHEX: 

DASCII: 

DASCI1: 

DASCI2: 


CALL 

BADDR 

JNC 

DMP3 

CLR 

ACC. 5 

CJNE 

A,#'I’,DMP1 

JMP 

DUMP I 

JMP 

WARM 

MOV 

FIRST,HIBYTE 

MOV 

(FIRST+1),LOBYTE 

MOV 

LAST,#0FFH 

MOV 

(LAST+1),#0FFH 

CJNE 

A,#CR,DMP4 

JMP 

(NEWLIN-6) 

CALL 

BADDR2 

JB 

F0,DMP5 

MOV 

LAST,HIBYTE 

MOV 

(LAST+1),LOBYTE 

MOV 

DPTR,#MINDEX 

LCALL 

PDATA 

MOV 

DPH,FIRST 

MOV 

DPL,(FIRST+1) 

ANL 

DPL,#0F0H 

CALL 

CRLF 

MOV 

R0.DPH 

CALL 

OUTR0 

MOV 

R0.DPL 

CALL 

OUTR0 

CALL 

OUT2S 

MOV 

A, (FIRST+1) 

XRL 

A, DPL 

JZ 

MORE 

CALL 

OUT3S 

INC 

DPTR 

CALL 

MIDCHK 

JMP 

SPACES 

CALL 

0UTC2HS 

MOV 

A,LAST 

CJNE 

A,DPH.MOREC 

MOV 

A,(LAST+1) 

CJNE 

A,DPL,MOREC 

JMP 

ENDHEX 

INC 

DPTR 

CALL 

MIDCHK 

JZ 

DASCII 

JMP 

MORE 

INC 

DPTR 

CALL 

MIDCHK 

JZ 

DASCII 

CALL 

0UT3S 

JMP 

ENDHEX 

CALL 

0UT4S 

MOV 

DPH,FIRST 

MOV 

DPL.(FIRST+1) 

ANL 

DPL,#0F0H 

MOV 

A, (FIRST+1) 

XRL 

A, DPL 

JZ 

DASCI2 

CALL 

OUTS 

INC 

DPTR 

CALL 

MIDCHK 

JMP 

DASCII 

CLR 

A 

MOVC 

A.GA+DPTR 

MOV 

B,A 

CLR 

C 


;CONVERT LOWER TO UPPER CASE 
;DUMP INTERNAL RAM 

;DUMP PROGRAM MEMORY 

;DEFAULT IF NO END ADDRESS ENTERED 

;CARRIAGE RETURN READ 


;DISPLAY ADDRESS 

;BLANK LOCATIONS BEFORE FIRST 
;JUMP IF EQUAL 


;NOW DUMP ASCII 

;NOW DUMP ASCII (LAST LINE) 

;SHOW ASCII EQUIVALENT 


( continued ) 
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SUBB 

A,#SPACE 



JC 

BAD3 



SUBB 

A,#(7FH-SPACE) 



JC 

0K3 


BAD3: 

MOV 

B.#DOT 


0K3: 

MOV 

A,B 



CALL 

OUTCH 



MOV 

A.LAST 



CJNE 

A.DPH.DASCI3 



MOV 

A,(LAST+1) 



CJNE 

A.DPL.DASCI3 



JMP 

WARM 


DASCI3: 

INC 

DPTR 



CALL 

MIDCHK 



JNZ 

DASCI2 



MOV 

A.#16 



ADD 

A,(FIRST+1) 



ANL 

A,#0F0H 



JNC 

$+4 



INC 

FIRST 



MOV 

(FIRST+1).A 



JMP 

NEWLIN 


;************************************************************* 

TABENT 


EQU 11 

;LENGTH OF SFR TABLE ENTRY 

OFF 1 


EQU 6 

;OFFSET TO HEX ADDRESS 

0FF2 


EQU 5 

;OFFSET TO FETCH CONTENTS 

0FF3 


EQU 8 

;OFFSET TO CHANGE CONTENTS 

DUMPI: 

CALL 

BADDR 



JNC 

$+5 



LJMP 

WARM 



MOV 

FIRST.LOBYTE 



MOV 

LAST,#0FFH 



XRL 

A,#CR 



JZ 

(LINE-6) 



CALL 

BADDR2 



JB 

F0.$+6 

;CARRIAGE RETURN READ 


MOV 

LAST.LOBYTE 



MOV 

A.#7FH 

;TOP OF RAM 


CLR 

C 



SUBB 

A.FIRST 



JC 

DSFR 

;DONE RAM—DO SFR’S 


MOV 

DPTR.#MINDEX 



LCALL 

PDATA 


LINE: 

CALL 

CRLF 



MOV 

A.#7FH 

;TOP OF RAM 


CLR 

C 



SUBB 

A,FIRST 



JC 

DSFR 

;DONE RAM—DO SFR'S 


MOV 

R0.FIRST 



ANL 

REG0,#0F0H 

;8«R0 


CALL 

OUTR03S 

;DISPLAY ADDRESS 

SPICES: 

MOV 

A.FIRST 

•.SPACES BEFORE BEGINNING 


XRL 

A, R0 



JZ 

NXTBYT 



CALL 

OUT3S 



INC 

R0 



MOV 

A,#07H 



ANL 

A.R0 



JNZ 

$+5 



LCALL 

OUTS 

jMIDDLE OF LINE 


JMP 

SPICES 


NXTBYT: 

CALL 

OUT2H 



CALL 

OUTS 



MOV 

A.R0 



XRL 

A.LAST 



JNZ 

$+5 



LJMP 

WARM 
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INC 

R0 



MOV 

A,#07H 



ANL 

A.R0 



JNZ 

$+5 



LCALL 

OUTS 

;MIDDLE OF LINE 


MOV 

A,#0FH 



ANL 

A,R0 



JNZ 

NXTBYT 

;NOT END OF LINE 


MOV 

A,FIRST 



ANL 

A,#0F0H 



ADD 

A.#10H 



MOV 

FIRST,A 



JMP 

LINE 


DSFR: 

MOV 

DPTR,#(SFRTAB-TABENT) 


MOV 

R1.#6 



CALL 

CRLF 


DSFR1: 

MOV 

A,#TABENT 



ADD 

A,DPL 



MOV 

DPL,A ' 



JNC 

$+4 



INC 

DPH 



MOV 

A,#OFF1 

;OFFSET TO SFR HEX LOCATION 


MOVC 

A,@A+DPTR 



CLR 

C 



SUBB 

A,FIRST 



JC 

DSFR1 

;NOT TO FIRST YET 

DSFR5: 

MOV 

A,#OFF1 



MOVC 

A,@A+DPTR 

;GET HEX LOCATION OF SFR 


MOV 

R0,FIRST 



XRL 

A, R0 



JZ 

DSFR10 



INC 

FIRST 

;WASN'T A VALID SFR 


MOV 

A,FIRST 



JZ 

(LINE-6) 

;BACK TO RAM 


CJNE 

A,LAST,DSFR5 



JMP 

WARM 

;DONE 

DSFR10: 

CALL 

OUTR0 



MOV 

A.#(*-’) 



CALL 

OUTCH 



CALL 

PDATA 

•.OUTPUT LOCATION LABEL (ALTERS DPTR) 


MOV 

A,#(':') 


CALL 

OUTCH 



MOV 

A,#LOW(DSFR20) 



PUSH 

ACC 



MOV 

A,#HIGH(DSFR20) 



PUSH 

ACC 



MOV 

A.#(0FF2-4) 

•.OFFSET TO "MOV R0.SFR" 


JMP 

©A+DPTR 


DSFR20: 

CALL 

OUTR0 



CALL 

OUT2S 



DJNZ 

R1.DSFR30 



MOV 

Rl.#6 



CALL 

CRLF 


DSFR30: 

INC 

FIRST 



MOV 

A,#(TABENT-4) 



ADD 

A, DPL 



MOV 

DPL. A 



JNC 

$+4 



INC 

DPH 



MOV 

A,FIRST 



JNZ 

$+5 



LJMP 

LINE 



DEC 

A 



XRL 

A,LAST 



JNZ 

DSFR5 



JMP 

WARM 



[continued] 
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COPY: 

CALL 

THRADR 


CALL 

CPY 


JMP 

WARM 

;** + + + + * + + + ***** + + + + *** + + + + + + ****** + *** + * + + + * + + + + * + * + * + * + * + * + * 

VERIFY: 

CALL 

THRADR 

VER10: 

MOV 

DPH,FIRST 


MOV 

DPL,(FIRST+1) 


CLR 

A 


MOVC 

A,©A+DPTR 


MOV 

R1 ,A 


MOV 

DPH,TO 


MOV 

DPL,(TO+1) 


CLR 

A 


MOVC 

A,©A+DPTR 


MOV 

R2, A 


XRL 

A.R1 


JZ 

VER20 ;JUMP IF EQUAL 


CALL 

CRLF 


MOV 

R0,#FIRST 


CALL 

OUT2H 


MOV 

R0,#(FIRST+1) 


CALL 

OUT2H 


CALL 

OUT2S 


MOV 

R0,#REG1 ;R1 


CALL 

OUT2H 


CALL 

0UT4S 


MOV 

R0,#TO 


CALL 

OUT2H 


MOV 

R0,#(TO+1) 


CALL 

OUT2H 


CALL 

OUT2S 


MOV 

R0,#REG2 ;R2 


CALL 

OUT2H 

VER20: 

MOV 

A,FIRST 


CJNE 

A,LAST,VER30 


MOV 

A,(FIRST+1) 


CJNE 

A,(LAST+1),VER30 


JMP 

WARM 

VER30: 

MOV 

R0,#(FIRST+1) 


CALL 

I NCI 6 


MOV 

R0,#(TO+1) 


CALL 

I NCI 6 


JMP 

VER10 

;************************************************************* 

ALTER: 

CALL 

BADDR 


JNC 

ALT05 


JNB 

F0,ALTEND ;ERROR 


CLR 

ACC.5 ;CONVERT LOWER TO UPPER CASE 


CJNE 

A,#(* I’).ALTEND ;ERROR 


JMP 

SUBSTUT 

ALT05: 

MOV 

FIRST,HIBYTE 


MOV 

(FIRST+1),LOBYTE 

ALT10: 

CALL 

CRLF 


MOV 

R0.#FIRST ;SHOW ADDRESS 


CALL 

0UT2H 


INC 

R0 


CALL 

OUT2H 

ALT15: 

CALL 

OUTS 


MOV 

DPH,FIRST 


MOV 

DPL,(FIRST+1) 


CLR 

A 


MOVC 

A,@A+DPTR ;GET DATA 


MOV 

R1 , A 


MOV 

R0,#REG1 ;SHOW DATA 


CALL 

OUT2H 


MOV 

A.#(•-') 


CALL 

OUTCH 


CALL 

BYTES 


JNC 

ALT20 


XRL 

A,#BACKSP 
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JZ 

BACKUP 




XRL 

A.#BACKSP 

;RESTORE A 



XRL 

A,#DOT 




JZ 

BACKUP 



ALTEND: 

JMP 

WARM 

;ERROR 


ALT20: 

JB 

F0.ALT30 

;<CR> OR SPACE 



MOV 

A.LOBYTE 




MOVX 

@DPTR.A 

•.CHANGE DATA 


ALT30: 

MOV 

R0,#(FIRST+1) 




CALL 

I NCI 6 




MOV 

A,B 




XRL 

A,#CR 




JZ 

ALT 10 




MOV 

A,(FIRST+1) 




ANL 

A,#07H 




JZ 

ALT 10 




JMP 

ALT 15 



BACKUP: 

MOV 

R0,#(FIRST+1) 




CALL 

DEC 16 




JMP 

ALT 10 



;************************************************************* 

MODIFY 

CALL 

BADDR 




MOV 

DPH.HIBYTE 




MOV 

DPL,LOBYTE 



MOD10: 

CALL 

INCH 




CJNE 

A,#BACKSP,NOTBS 




DEC 

DPL 




MOV 

A.#0FFH 




CJNE 

A,DPL,MOD10 




DEC 

DPH 




JMP 

MOD 10 



NOTBS: 

CJNE 

A.#EOT.$+6 




LJMP 

WARM 




MOVX 

©DPTR,A 




INC 

DPTR 




JMP 

MOD 10 



;************************************************************* 

SUBSTUT 

. 





CALL 

BADDR 




MOV 

R0,LOBYTE 



IF010: 

MOV 

A,#7FH 

;IF ADDRESS >- 80H OR <= 

F0H 


CLR 

C 




SUBB 

A, R0 




JNC 

ELS010 




MOV 

A,#0F0H 




CLR 

C 




SUBB 

A, R0 




JC 

ELS010 



THN010: 

MOV 

DPTR,#(SFRTAB-TABENT) 


SUB60: 

MOV 

A,#TABENT 

;INCREMENT TABLE POINTER 



ADD 

A, DPL 




MOV 

DPL. A 




JNC 

$+4 




INC 

DPH 




MOV 

A.#OFF1 

;FIND 1ST ENTRY >= R0 



MOVC 

A,®A+DPTR 




CLR 

C 




SUBB 

A, R0 




JC 

SUB60 

;NOT FOUND YET 


SUB65: 

MOV 

A.#OFF1 

;INCREMENT R0 TO LINE IN 

TABLE 


MOVC 

A,®A+DPTR 




XRL 

A, R0 




JZ 

SUB70 

;FOUND IT 



INC 

R0 




JMP 

SUB65 



ELS010: 

JMP 

LS010 

;RELAY STATION 



(continued) 
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SUB70: 

CALL 

CRLF 


CALL 

OUTR03S 


CALL 

PDATA 


MOV 

A.#(’:•) 


CALL 

OUTCH 


MOV 

REG1.R0 


MOV 

A,#LOW(SUB80) 


PUSH 

ACC 


MOV 

A,#HIGH(SUB80) 


PUSH 

ACC 


MOV 

A,#(0FF2-4) 


JMP 

©A+DPTR 

SUB80: 

CALL 

OUTR0 


MOV 

A.#(’-’) 


CALL 

OUTCH 


MOV 

R0.REG1 


CALL 

BYTES 

IF020: 

JNC 

ELS020 


MOV 

A,B 


XRL 

A,#BACKSP 


JZ 

THN020 


MOV 

A.B 


XRL 

A,#DOT 


JZ 

THN020 


JMP 

WARM 

THN020: 

IF030: 

CJNE 

R0.#80H,ELS030 

THN030: 

MOV 

R0.#7FH 


JMP 

IF010 

ELS030: 

MOV 

A.DPL 


CLR 

C 


SUBB 

A,#(TABENT+4) 


MOV 

DPL, A 


JNC 

$+4 


DEC 

DPH 


MOV 

A.#(0FF1) 


MOVC 

A,@A+DPTR 


MOV 

R0, A 


JMP 

IF010 

ELS020: 


JB 

F0.SUB90 


SETB 

F0 


MOV 

R0.LOBYTE 


MOV 

A,#LOW(SUB90) 


PUSH 

ACC 


MOV 

A,#HIGH(SUB90) 


PUSH 

ACC 


MOV 

A,#(0FF3-4) 


JMP 

OA+DPTR 

SUB90: 

MOV 

R0.REG1 

IF035: 

JB 

F0,NDI035 

THN035: 

MOV 

DPTR.#MNONO 


CALL 

PDATA 

NDI035: 

IF040: 

CJNE 

R0,#0F0H.NDI040 

THN040: 

MOV 

R0,#0FFH 

NDI040: 


INC 

R0 


JMP 

IF010 

LS010: 

CALL 

CRLF 


CALL 

OUTR03S 

SUB20: 

CALL 

0UT2H 


MOV 

A. #C-*> 


CALL 

OUTCH 


MOV 

REG1,R0 


CALL 

BYTES 


MOV 

R0.REG1 

IF050: 

JNC 

ELS050 


MOV 

A,B 


XRL 

A,#BACKSP 


JZ 

THN050 


;DISPLAY ADDRESS 
;ALTERS DPTR (ADDS 4) 

;MOV R1,R0 


;CRASHES R0 
;DISPLAY DATA 

;RESTORE R0 

;IF CHARACTER - DOT OR BACKSPACE 


;ERROR 

;THEN BACKUP 


;CRASHES R0 
;RESTORE R0 

;IF R0 = 0F 
;THEN R0 - FFH 


;clobbers r0 

;IF CHAR. - BACKSP. OR DOT 
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MOV 

A.B 


XRL 

A,#DOT 


JZ 

THN050 


JMP 

WARM 


THN050: 

» 

THEN BACKUP 

IF060: MOV 

A, R0 


JNZ 

NDI060 ; 

IF R0 = 0 

THN060: MOV 

R0,#0F1H ; 

THEN R0 = F1H 

NDI060: 

NDI050: 

DEC 

R0 


F010: JMP 

IF010 ; 

ALSO USED FOR RELAY 

ELS050: 

IF070: JB 

F0.NDI070 ; 

IF NOT SPACE OR CR 

THN070: MOV 

A,LOBYTE 

THEN CHANGE BYTE 

MOV 

@R0, A 


NDI070: INC 

R0 


MOV 

A,#07H 


ANL 

A,R0 


JZ 

F010 


CALL 

0UT2S 


JMP 

SUB20 


;************************************************************* 

INSERT: CALL 

THRADR 


MOV 

DPH,FIRST 


MOV 

DPL,(FIRST+1) 


INS10: MOV 

A, (TO+1) 


MOVX 

@DPTR,A 


MOV 

A, DPH 


CJNE 

A,LAST,INS20 


MOV 

A, DPL 


CJNE 

A,(LAST+1),INS20 


JMP 

WARM 


INS20: INC 

DPTR 


JMP 

INS10 



************************************************************* 


BREAK: 

MOV 

CLR 

MOVC 

MOV 

IF100: JZ 

THN100: MOV 
MOV 
MOV 
MOV 
ADD 
MOV 
JNC 
INC 
MOV 
CLR 
MOVC 
MOV 
MOV 
CLR 
MOVC 
CLR 
SUBB 
MOV 
JNC 
DEC 
CALL 
CLR 
MOV 
MOV 

CLEAR1: MOVX 
INC 
DJNZ 


; REMOVE OLD BREAKPOINT 
DPTR,#BYTENUM 
A 

A,®A+DPTR 

R1,A ;SAVE OLD BYTENUM IN R1 

NDI100 ;IF THERE IS AN OLD BREAKPOINT 

FIRST,#HIGH(BYTENUM+1) ;THEN REMOVE IT 
FIRST+1,#LOW(BYTENUM+1) 

LAST,#HIGH(BYTENUM) 

A,#LOW(BYTENUM) 

A,R1 ;ADD OLD BYTENUM 

LAST+1.A 

$+4 

LAST 

DPTR,#(RAMEND-1) 

A 

A,@A+DPTR 
TO,A 

DPTR,#RAMEND 

A 

A,©A+DPTR 
C 

A,R1 ;SUBTRACT OLD BYTENUM 

TO+1,A 

$+4 

T0 

CPY 

A ;CLEAR END OF RAM 

DPTR,#BYTENUM 

R0,#(RAMEND-BYTENUM+1-3) ;LEAVE JUMP INSTRUCTION 

®DPTR,A 

DPTR 

R0.CLEAR1 


(continued) 
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NDI100: 

CALL 

BYTES 

;INSTALL NEW BREAKPOINT 

IF150: JNC 

NDI150 

;IF NOT VALID HEX 

JMP 

WARM 

;THEN END 

NDI150: 

IF155: JNB 

F0,NDI155 

; IF CR 

XRL 

A,#SPACE 


JZ 

NDI100 

;AND NOT SPACE 

JMP 

WARM 

;THEN END 

NDI155: MOV 

FIRST,HIBYTE 


MOV 

FIRST+1,LOBYTE 


MOV 

DPTR,#BYTENUM 


MOV 

A,#3 

;IN CASE OF DEFAULT 

MOVX 

©DPTR.A 


MOV 

R1.A 

;SAVE DEFAULT NEW BYTENUM 

IF160: MOV 

A, B 


XRL 

A,#CR 


JZ 

NDI160 


THN160: CALL 

INHEX 

;get BYTENUM 

IF170: JNC 

ELS170 

; Tf not valid hex 

THN170: MOV 

A, B 

;then check for space or CR 

XRL 

A,#SPACE 

JZ 

THN160 


MOV 

A,B 


XRL 

A,#CR 


JZ 

NDI170 


MOV 

DPTR,#BYTENUM 


CLR 

A 


MOVX 

©DPTR.A 


JMP 

WARM 


ELS170: MOV 

DPTR,#BYTENUM 

;else accept only 3, 4 or 5 

MOVX 

©DPTR.A 

MOV 

R1, A 

;SAVE NEW BYTENUM 

SUBB 

A.#3 


JC 

BAD4 


SUBB 

A.#(6-3) 


JNC 

BAD4 


JMP 

NDI170 


BAD4: MOV 

DPTR,#BYTENUM 


CLR 

A 


MOVX 

©DPTR,A 


JMP 

WARM 


NDI170: 

NDI160: 

MOV 

DPTR,#(RAMEND-2) 

;FIRST,FIRST+1 AND HIBYTE,LOBYTE 
; BOTH CONTAIN BREAK ADDRESS 
;R1 CONTAINS NEW BYTENUM 

MOV 

A,#02H 

;"LJMP" 

MOVX 

©DPTR.A 


MOV 

A,FIRST+1 


ADD 

A,R1 

;ADD BYTENUM 

MOV 

LAST+1,A 


MOV 

DPTR,#RAMEND 


MOVX 

©DPTR,A 


MOV 

A,FIRST 


JNC 

$+3 


INC 

A 


MOV 

LAST,A 


MOV 

DPTR,#(RAMEND-1) 


MOVX 

©DPTR.A 


MOV 

R0,#(LAST+1) 

;ADJUST (LAST,LAST+1) 

CALL 

DEC 16 

MOV 

TO.#HIGH(BYTENUM+1) 

MOV 

TO+1,#LOW(BYTENUM+1) 

CALL 

CPY 

;SAVE INSTRUCTIONS IN END OF RAM 

MOV 

DPL,LOBYTE 


MOV 

DPH,HIBYTE 

;INSERT JUMP TO BRKPT 

MOV 

A,#02H 

;"LJMP" 

MOVX 

©DPTR.A 


INC 

DPTR 
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MOV 

A,#HIGH(BRKPT) 

MOVX 

@DPTR,A 

INC 

DPTR 

MOV 

A,#LOW(BRKPT) 

MOVX 

@DPTR,A 

JMP 

WARM 


;************************************************************* 


BRKPT: 


PUSH ACC 

PUSH PSW 

PUSH B 

PUSH DPH 

PUSH DPL 

MOV STACK,SP ;save current stack level for cool start 

SETB RS0 ;SELECT REGISTER BANK 1 

CLR RSI 

MOV DPTR,#MBRK1 

CALL PDATA 

MOV DPTR,#(BYTENUM) 

CLR A 

MOVC A,®A+DPTR 

MOV R0,A 

MOV DPTR,#(RAMEND) 

CLR A 

MOVC A,©A+DPTR 

CLR C 

SUBB A,R0 

MOV B A 

MOV DPTR.#(RAMEND-1) 

CLR A 

MOVC A,@A+DPTR 

MOV R0,A 

JNC $+3 

DEC R0 

CALL OUTR0 

MOV R0,B 

CALL OUTR0 

MOV DPTR,#M8RK2 

CALL PDATA 

MOV A.STACK 

CLR C 

SUBB A,#4 

MOV R0,A 

CALL OUT2H 

MOV DPTR,#M8RK3 

CALL PDATA 

INC R0 

CALL OUT2H 

MOV DPTR,#MBRK4 

CALL PDATA 

INC R0 

CALL OUT2H 

MOV DPTR,#MBRK5 

CALL PDATA 

INC R0 

CALL OUT2H 

INC R0 

CALL 0UT2H 

MOV DPTR,#MBRK6 

CALL PDATA 

MOV R0,#STACK 

CALL 0UT2H 

JMP WARM 


;************************************************************* 


CALL 

BYTES 


JNC 

$+5 


LJMP 

WARM 


JNB 

F0.GXXXX 


CJNE 

A, #CR,GO 

;LOOK AGAIN IF SPACE 

MOV 

HIBYTE.#HIGH(BYTENUM+1) 


MOV 

LOBYTE,#LOW(BYTENUM+1) 


MOV 

SP,STACK 

{restore stack If necessary 


(continued) 
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GXXXX: 


POP 

DPL 

POP 

DPH 

POP 

B 

POP 

PSW 

POP 

ACC 

PUSH 

LOBYTE 

PUSH 

RET 

HIBYTE 


;***********.****************.**.******** 

HEXMATH: 

CALL BADDR 

JNC $ +5 

LJMP WARM 


MOV FIRST,HIBYTE 

MOV (FIRST+1),LOBYTE 

CALL BADDR 

JNC $+5 

LJMP WARM 


MOV 

ADD 

MOV 

MOV 

ADDC 

MOV 


A,(FIRST+1) 
A,LOBYTE 
(LAST+1),A 
A,FIRST 
A.HIBYTE 
LAST,A 


MOV 

CLR 

SUBB 

MOV 

MOV 

SUBB 

MOV 

CALL 

MOV 

CALL 

MOV 

CALL 

CALL 

MOV 

CALL 

MOV 

CALL 

CALL 

MOV 

CALL 

CALL 

MOV 

CALL 

MOV 

CALL 

CALL 

MOV 

CALL 

MOV 

CALL 

CALL 

MOV 

CALL 

JMP 


A, (FIRST+1) 

A,LOBYTE 
(TO+1).A 
A,FIRST 
A.HIBYTE 
TO.A 
CRLF 

R0.#FIRST 

0UT4HS 

OUTCH 

OUTS 

R0,#HIBYTE 
0UT4HS 
A.#*-• 

OUTCH 

OUTS 

R0.#LAST 

0UT4HS 

CRLF 

R0.#FIRST 

0UT4HS 

A.#'-' 

OUTCH 

OUTS 

R0.#HIBYTE 

0UT4HS 

A 

OUTCH 

OUTS 

R0.#TO 

0UT4HS 

WARM 


:STORE LOW BYTE OF SUM 
;STORE HIGH BYTE OF SUM 


;STORE LOW BYTE OF DIFFERENCE 

;STORE HIGH BYTE OF DIFFERENCE 
;POINT TO ADDEND 

:POINT TO AUGEND 

.•POINT TO SUM 
;POINT TO SUBTRAHEND 

:POINT TO MINUEND 

;POINT TO DIFFERENCE 


. Wwimi 

JUMPTABL: 


MOV 

CALL 

JMP 


DPTR,#MJUMP 

PDATA 

WARM 


PAGE 

**************^* #4 , <l4ti([l| 


routine pdata 

WRITES A MESSAGE TO THE TERMINAL 
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; ENTER WITH DPTR POINTING 

TO BEGINNING OF MESSAGE 

; AND 04H 

AT END OF MESSAGE 

• 

PDATA1: CALL 

OUTCH 


INC 

DPTR 


PDATA: CLR 

A 


MOVC 

CJNE 

RET 

A,@A+DPTR 

A,#EOT,PDATA1 


;************************************************************* 

•ROUTINE 

IN 


; READ AN 

8-BIT CHAR FROM 8251A UART 

IN: PUSH 

DPH 


PUSH 

DPL 


MOV 

DPTR.#UARTCONT 


MOVX 

A, ©DPTR 


JNB 

ACC.1,$-1 ; 

WAIT FOR RX RDY 

DEC 

DPL ; 

POINT TO DATA REGISTER 

MOVX 

A,©DPTR 


POP 

DPL 


POP 

DPH 


RET 



;************************************************************* 

• ROUTINE 

INCH 


; READ A 

CHARACTER, ZERO HIGH BIT, k ECHO BACK TO TERMINAL 

INCH: CALL 

IN 

READ 8-BIT CHAR. 

ANL 

A,#7FH 

ZERO HIGH BIT 

JMP 

OUT 

ECHO BACK 

;************************************************************* 

;ROUTINE 

OUTCH 


; OUTPUT 

A CHARACTER 


OUTCH: CALL 

OUT 


JNC 

NOINPU 

TEST FOR INPUT DURING OUTPUT 

CALL 

IN 

GET RID OF THE CHARACTER 

JMP 

COOL 

RESET STACK POINTER 

NOINPU: RET 



;************************************************************* 

;ROUTINE 

OUT 


; SEND "A" REGISTER TO UART 

; SET CARRY IF RX BUFFER IS FULL 

OUT: PUSH 

DPH 


PUSH 

DPL 


PUSH 

ACC 

;SAVE OUTPUT BYTE 

MOV 

DPTR,#UARTCONT 


MOVX 

A,©DPTR 


JNB 

ACC.0,$-1 

WAIT FOR TX EMPTY 

MOV 

C.ACC.1 

MOV RX RDY TO CARRY 

DEC 

DPL 

POINT TO DATA REGISTER 

POP 

ACC 

RESTORE OUTPUT BYTE 

MOVX 

©DPTR,A 

AND OUTPUT IT 

POP 

DPL 


POP 

DPH 


RET 



PAGE 

30 



* * * 4c ** 414c 41* *** * ** *** * *** **** ** ** ** ********* *********** **** ** * * 

ROUTINE INHEX 

READS 1 ASCII HEX CHAR, CONVERTS TO BINARY IN ACC. k 
STORES ORIGINAL CHAR IN B REG. 

CARRY SET IF NOT VALID HEX, CLEARED OTHERWISE. 


( 1 continued) 
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INHEX: 

CALL 

INCH 

;GET CHARACTER 


MOV 

B.A 

; STORE IN B 


CJNE 

A,#CR,NOTCR 

;IF <CR> SEND <LF> ALSO 


MOV 

a.#lf 



CALL 

OUTCH 


NOTCR: 

MOV 

A.B 

; RESTORE CHARACTER 


JNB 

ACC.6.$+5 

; IF LOWER CASE 


CLR 

ACC. 5 

;CONVERT TO UPPER CASE 


CLR 

C 



SUBB 

A.#’0’ 



JC 

BAD 

; ACC < * 0 * 


SUBB 

A.#10 



JNC 

$+7 

; ACC > * 9 * 


ADD 

A,#10 ;RESTORE 


LJMP 

GOOD 

; * 0 * <- ACC <« ’9' 


ADD 

A.K’e’+ie-'A' 

’+10) ; CORRECT FOR (- 


JB 

ACC.7,BAD 

; *9* < ACC < ‘A* 


CLR 

C 



SUBB 

A,#16 



JNC 

BAD 

; ACC > *F # 


ADD 

A.#16 


GOOD: 

CLR 

C 



RET 



BAD: 

SETB 

C 



RET 




******************************#*********#*#**************,,,,„** 
ROUTINE BYTES 

READ IN TWO BYTE HEX NUMBER TO HIBYTE.LOBYTE 
LAST CHARACTER READ RETURNED IN B REGISTER 

ERROR CODES: CARRY: F0: 

LEADING <CR> OR SPACE 0 1 (CHAR IN ACC) 

LEADING NONHEX CHARACTER 1 1 (CHAR IN ACC) 

OTHER NONHEX CHARACTER 1 0 (CHAR IN ACC) 


BYTES: 

SETB 

F0 

;NO HEX READ YET 


CLR 

A 



MOV 

HIBYTE,A 



MOV 

LOBYTE,A 


MORE1: 

CALL 

INHEX 



JNC 

OKI | 

iJUMP IF HEX DIGIT 


MOV 

A.B 

;LOOK AT ASCII 


CJNE 

A,#CR,$+6 



LJMP 

CR1 



CJNE 

A,#SPACE,BAD1 


CR1: 

CLR 

C 



RET 



OKI: 

CLR 

F0 



MOV 

R0,#LOBYTE 

POINTER 


XCHD 

A,@R0 

PUT 0 DIGIT IN LOW END OF LOBYTE 


SWAP 

A 

ACC NOW HAS DIGIT 1 IN HIGH END 


XCHD 

A,@R0 

ACC NOW HAS DIGITS 1.0 


XCH 

A,@R0 

ACC HAS DIGITS 2,X;LOBYTE DONE. 


DEC 

R0 

POINT TO HIBYTE 


XCHD 

A,@R0 

ACC NOW HAS DIGITS 2.3 


SWAP 

A 

ACC HAS DIGITS 3,2 


XCH 

A,@R0 

HIBYTE DONE 


JMP 

MORE1 

LOOK FOR ANOTHER DIGIT 

BAD1: 

SETB 

RET 

C 



PAGE 

19 


;************************************************************* 

•ROUTINE 

BUILD ADDRESS 


t 

READ IN 

A 16-BIT HEX NUMBER TO HIBYTE.LOBYTE. 

» 

RETURNS 

WITH CARRY & F0 SET IF A SECOND COMMAND CHARACTER 


IS FOUND. CHARACTER WILL BE IN ACCUMULATOR. 
RETURNS WITH CARRY SET AND F0 CLEAR IF NON-HEX. 
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BADDR: 


ADDRNOK: 


CALL 

BYTES 

JNC 

ADDROK 

JB 

F0.ADDRNOK 

JMP 

WARM 

JB 

F0.BADDR 

RET 



SECOND COMMAND CHARACTER 
ERROR 

LEADING SPACE OR CR 


************************************************************* 


;ROUTINE 

BUILD ADDRESS #2 

; READ IN 

A 16-BIT HEX NUMBER TO HIBYTE.LOBYTE. 

; IGNORES 

LEADING SPACES. RETURNS WITH F0 SET IF 

; A LEADING CARRIAGE RETURN IS FOUND. 

BADDR2: CALL 

BYTES 

JNC 

$+5 

LJMP 

WARM ;NON-HEX 

JNB 

F0.ADDROK2 ;NUMBER READ 

CJNE 

A,#CR,BADDR2 ;IGNORE LEADING SPACE 

ADDROK2: 


RET 


;************************************************************* 

;ROUTINE 

OUTPUT SPACES 

; OUTPUTS 

1. 2. 3, OR 4 SPACES 

0UT4S: CALL 

OUTS 

0UT3S: CALL 

OUTS 

0UT2S: CALL 

OUTS 

OUTS: MOV 

A.#SPACE 

JMP 

OUTCH 

;************************************************************* 

•ROUTINE 

OUTPUT CODE, TWO HEX, SPACE 

: OUTPUTS 

PROGRAM MEMORY BYTE POINTED OUT BY DPTR 

; AS TWO ASCII CHARACTERS FOLLOWED BY A SPACE. 

; USES B REGISTER AS TEMP. STORE 

OUTC2HS: 


CLR 

A 

MOVC 

A.@A+DPTR 

MOV 

B,A ;TEMP STORE 

CALL 

OUTHL 

MOV 

A.B 

CALL 

OUTHR 

JMP 

OUTS 

I************************************************************* 

;ROUTINE 

MIDCHK 

; INSERTS 

A SPACE IF LOW NYBBLE OF DPTR « 8. 

: RETURNS 

WITH LOW NYBBLE IN ACC. 

; DESTROYS B REGISTER. 

MIDCHK: MOV 

A.DPL 

ANL 

A.#0FH 

XRL 

A.#08H 

JNZ 

NOTMID 

XCH 

A.B 

CALL 

OUTS 

XCH 

A.B 

NOTMID: XRL 

A,#08H ;RESTORE A 


RET 


PAGE 14 

************************************************************* 

ROUTINES OUTPUT HEX LEFT 

OUTPUT HEX RIGHT 

CONVERTS A NYBBLE IN ACC. TO ASCII AND SENDS IT 


( continued ) 


BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 247 










July 




OUTHL: 

SWAP 

A 


OUTHR: 

ANL 

A,#0FH 



JNB 

ACC.3.H2 

5 <8 


JB 

ACC.2,HI 

:>-c 


JNB 

ACC.1.H2 

;<A 

HI: 

ADD 

A,#07H 


H2: 

ADD 

A.#C0 # ) 

;CONVERT TO ASCII 


JMP 

OUTCH 



PAGE 

9 



********************************************* *********** ***** 


ROUTINE 


OUTPUT TWO HEX 
OUTPUTS HEX CONTENTS OF LOCATION POINTED OUT BY R0 


0UT2H: 


MOV 

CALL 

MOV 

JMP 


A,@R0 

OUTHL 

A,@R0 

OUTHR 


************************************************************* 
ROUTINE CRLF 

SENDS A CARRIAGE RETURN AND A LINE FEED 


CRLF: 


MOV 

CALL 

MOV 

JMP 


A,#CR 

OUTCH 

A.#LF 

OUTCH 


************************************************************* 

ROUTINE DECREMENT 16 

DECREMENTS A 16-BIT NUMBER POINTED OUT BY R0. 

ENTER WITH LOW BYTE @R0 k HIGH BYTE @(R0-1). 

CARRY SET ON OVERFLOW, CLEARED OTHERWISE. 


DEC16: 

clr 

C 


DEC 

@R0 


MOV 

A,©R0 


CPL 

A 


JNZ 

DECEND 


DEC 

R0 


DEC 

®R0 


MOV 

A,@R0 


CPL 

A 


JNZ 

DECEND 


SETB 

C 

DECEND: 

RET 



PAGE 

17 

;************************************************************* 

• ROUTINE 

INCREMENT 16 


INCREMENTS A 16-BIT NUMBER POINTED OUT BY R0. 

ENTER WITH LOW BYTE @R0 k HIGH BYTE @(R0-1). 


CARRY 

SET ON OVERFLOW, CLEARED OTHERWISE. 

INCI 6: 

CLR 

C 


INC 

@R0 


MOV 

A,@R0 


JNZ 

INCEND 


DEC 

R0 


INC 

@R0 


MOV 

A,@R0 


JNZ 

INCEND 


SETB 

C 

INCEND: 

RET 



PAGE 

20 

;************************************************************* 

•[routine 

THREE ADRESSES 


GETS THREE 16-BIT HEX NUMBERS AND STORES THEM IN 


M FIRST 

", "LAST", AND "TO" RESPECTIVELY. 
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THRADR: CALL 

BADDR 

JC 

THRERR 

MOV 

FIRST,HIBYTE 

MOV 

(FIRST+1),LOBYTE 

CALL 

BADDR 

JC 

THRERR 

MOV 

LAST,HIBYTE 

MOV 

(LAST+1).LOBYTE 

CALL 

BADDR 

JC 

THRERR 

MOV 

TO.HIBYTE 

MOV 

(TO+1),LOBYTE 

RET 

THRERR: JMP 

COOL 

;************************************************************* 

;ROUTINE 

COPY 

; COPIES 

PROGRAM MEMORY LOCATED "FIRST" TO "LAST" 

; TO RAM 

LOCATION STARTING AT "TO" 

CPY: MOV 

DPH,FIRST 

MOV 

DPL,(FIRST+1) 

CLR 

A 

MOVC 

A.GA+DPTR 

MOV 

DPH.TO 

MOV 

DPL,(TO+1) 

MOVX 

@DPTR,A ;PUT DATA 

MOV 

A,FIRST 

CJNE 

A,LAST.CPY2 

MOV 

A,(FIRST+1) 

CJNE 

A,(LAST+1),CPY2 

RET 

;DONE 

CPY2: MOV 

R0,#(FIRST+1) 

n CALL 

I NCI 6 

MOV 

R0,#(TO+1) 

CALL 

INC16 

JMP 

CPY 

;************************************************************* 

•ROUTINE 

OUT, 2 HEX, 3 SPACES 

; OUTPUTS 

LOCATION POINTED OUT BY R0 FOLLOWED BY 3 SPACES 

OUT2H3S: 

CALL 

0UT2H 

JMP 

0UT3S 

PAGE 

11 

; ************************************************************* 

;ROUTINE 

OUTPUT R0 

; OUTPUTS 

THE CONTENTS OF R0 

; (8051 CAN’T ACCESS SFR’S INDIRECTLY—UGH) 

OUTR0: MOV 

A,R0 

CALL 

OUTHL 

MOV 

A,R0 

JMP 

OUTHR 

PAGE 

9 

;************************************************************* 

•ROUTINE 

OUTPUT R0, 3 SPACES 

; OUTPUTS 

THE CONTENTS OF R0 AND THREE SPACES 

OUTR03S: 

CALL 

OUTR0 

JMP 

0UT3S 

;************************************************************* 

;ROUTINE 

OUTPUT FOUR HEX. SPACE 


( continued ) 
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OUTPUTS TWO CONSECUTIVE INTERNAL MEMORY LOCATIONS. 
OUT B? W R0 ° F WHICH ( HIGH BYTE 0F NUMBER ) Is POINTED 


0UT4HS: CALL 

0UT2H 

INC 

R0 

CALL 

0UT2H 

JMP 

OUTS 

PAGE 


;************»*********************,**,,,,, ***,#* **************** 

FUNTAB: 

;FUNCTION TABLE 

DB 

*A* 

DW 

ALTER 

DB 

’B* 

DW 

BREAK 

DB 

’C’ 

DW 

COPY 

DB 

’D’ 

DW 

DUMP 

DB 

•G* 

DW 

GO 

DB 

'H* 

DW 

HELP 

DB 

•r 

DW 

INSERT 

DB 

•J’ 

DW 

JUMPTABL 

DB 

•M’ 

DW 

MODIFY 

DB 

•V 1 

DW 

VERIFY 

DB 

’#• 

DW 

HEXMATH 

DB 

00H ;END OF TABLE 


SFRTAB: 

;SPECIAL FUNCTION REGISTER TABLE 

DB 

•P0 *, 04H 

MOV 

R0,P0 

RET 

CLR 

F0 

RET 


DB 

'SP *,04H 

MOV 

R0,SP 

RET 


CLR 

F0 

RET 


DB 

'DPL \04H 

MOV 

R0.DPL 

RET 


MOV 

DPL.R0 

RET 


DB 

*DPH • t 04H 

MOV 

R0.DPH 

RET 

MOV 

DPL.R0 

RET 


DB 

* PCON *,04H 

MOV 

R0,PCON 

RET 


MOV 

PCON.R0 

RET 

DB 

*TCON*,04H 

MOV 

R0.TCON 

RET 


MOV 

TCON.R0 

RET 

DB 

* TMOD *,04H 

MOV 

R0,TMOD 

RET 


MOV 

TMOD.R0 

RET 

DB 

’TL0 • # 04H 
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MOV 

R0.TL0 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

CLR 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

RET 

DB 

MOV 

RET 

MOV 

TL0.R0 

•TL1 *,04H 

R0.TL1 

TL1.R0 

•TH0 *,04H 

R0.TH0 

TH0.R0 

*TH1 \04H 

R0.TH1 

TH1,R0 

’PI ’,04H 

R0.P1 

P1.R0 

* SCON *.04H 

R0.SCON 

SCON.R0 

•SBUF*,04H 

R0.SBUF 

SBUF.R0 

•P2 ’,04H 

R0.P2 

F0 

'IE *,04H 

R0.IE 

IE ,R0 

• P3 *.04H 

R0.P3 

P3.R0 

•IP ’,04H 

R0.IP 

IP.R0 

•PSW ’,04H 

R0.PSW 

PSW.R0 

•ACC ’,04H 

R0.ACC 

ACC.R0 

•B *,04H 

R0.B 

B,R0 


RET 

************************************************************* 


MPROMPT: 

DB 

CR,LF,’UGH:*.04H 

(continu«f) 
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MHELP: 


MBRK1: 

MBRK2: 

MBRK3: 

MBRK4: 

MBRK5: 

MBRK6: 

MINDEX: 

MNONO: 

MJUMP: 


DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 


CR.LF,’REGISTER BANK 1 IS RESERVED’ 

CR,LF,* LAST 9 BYTES OF EXT. RAM USED BY BREAK ROUTINE* 

CR,LF,’ RAM 0 48H-50H IS USED BY MONITOR* 

CR.LF,’RAM ABOVE 50H IS USED FOR STACK’,LF 
CR.LF,’COMMANDS ARE *,LF 

CR,LF,*A SSSS*,TAB,TAB,TAB,’ALTER EXTERNAL MEMORY* 

CR,LF,*AI SS’.TAB,TAB,TAB,’ALTER INTERNAL MEMORY’ 

CR.LF.’B {AAAA {#}}*.TAB,TAB,’BREAK e AAAA (#-3,4,OR 5) 

CR,LF,*C SSSS FFFF TTTT’,TAB,’COPY BLOCK OF MEMORY’ 

CR,LF,*D SSSS {FFFF}’,TAB,TAB,’DUMP PROGRAM MEMORY’ 

CR.LF,’DISS {FF}’,TAB,TAB,’DUMP INTERNAL MEMORY’ 

CR.LF,*G {AAAA}’,TAB,TAB,’GO @ AAAA OR BREAKPOINT’ 

CR.LF,*H’.TAB,TAB,TAB.’HELP’ 

CR.LF,* I SSSS FFFF HH’,TAB,TAB,* INSERT "HH” INTO MEMORY’ 
CR.LF,’J’, TAB, TAB,TAB, ’LIST JUMP TABLE’ 

CR.LF,*M SSSS’,TAB,TAB,TAB,’MODIFY EXTERNAL MEMORY (ASCII)’ 
CR.LF,’V SSSS FFFF TTTT’,TAB,’VERIFY MEMORY’ 

CR.LF,’# MMMM NNNN *.TAB,TAB,’HEX ADDITION & SUBTRACTION* 
CR.LF,04H 


DB CR.LF,’BREAK AT LOCATION \04H 

DB CR.LF,’ACC - \04H 

DB ’ PSW - ’,04H 

DB • B - *,04H 

DB ’ DPTR - ’,04H 

DB ’ SP - *,04H 

DB CR.LF,* 01234567 89ABCDE F’,04H 

DB CR.LF,’OOPS, THAT’,27H,’S A NO-NO !’,04H 


DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

DB 

END 


CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 

CR.LF, 


’0026 
*0029 
’ 002C 

* 002F 
*0032 
*0035 
’0038 

* 003B 
’ 003E 
*0041 
*0044 
’0047 
*004A 

* 004D 
’0050 
*0053 


COOL’,TAB, ’COOL START (RESET STACK POINTER)’ 
WARM’.TAB, ’WARM START’ 

IN’,TAB. ’GET A BYTE FROM THE UART* 

INCH’,TAB, ’GET A CHARACTER (ZERO PARITY)’ 
INHEX’,TAB. ’GET A HEX CHAR (CARRY-NONHEX)’ 
BYTES’.TAB, *2 BYTE HEX TO HI/LOBYTE’ 

BADDR*,TAB, ’BUILD ADDRESS * 

THRADR*,TAB, ’THREE ADDRESSES’ 

OUT’.TAB, ’OUTPUT BYTE IN ACC.’ 

OUTCH’.TAB, ’OUTPUT CHARACTER IN ACC.’ 

OUTS’.TAB, ’OUTPUT SPACE’ 

OUT2S*.TAB, ’OUTPUT 2 SPACES’ 

CRLF’.TAB, ’OUTPUT [CR] AND [LF]’ 

OUT2H*,TAB, ’OUTPUT LOC. POINTED BY R0’ 

OUTR0’,TAB, ’OUTPUT CONTENTS OF R0* 

OUTC2HS*,TAB, ’OUTPUT PROG. MEM. POINTED* 
SPACE’ 

PDATA’.TAB, ’OUTPUT MESSAGE POINTED BY DPTR’ 
INC16’,TAB, ’INCREMENT 2 BYTE NO.’ 


* BY DPTR, AND 
CR.LF, *0056 
CR.LF, *0059 
’ (R0-LOW BYTE)’ 

CR.LF, ’005C DEC16’.TAB, ’DECREMENT 2 BYTE NO 
’ (R0+1-HIGH BYTE)’ 

CR.LF, *005F CPY’.TAB, ’BLOCK COPY’ 

CR.LF, *0062 BRKPT’.TAB. ’BREAKPOINT ROUTINE* 

04H 
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density.src 

Programming Insight:"PoIar Normal Distribution," by 
Alain Latour. August, page 131. Also see normal.src. 


function NormDens (x : real) : real; 
const c - 0.3989422804; 
begin 

NormDens :« c * exp(-sqr(x) / 2) 

end; 


function NormProb (x : Real) : Real; 

const b0 - +0.319381530; bl = -0.356563782; 

b2 - +1.781477937; b3 « -1.821255978; 
b4 - +1.330274429; p - +0.2316419; 
var Temp, t : Rea I; 

Positive : Boolean; 


begin 

Positive :■ x > 0; 
x Abs(x); 

t 1 / (1 + p * X); 

Temp NormDens(x)*t*(b0+t*(b1+t* 
(b2+t*(b3+b4*t)))); 

If Positive then Temp :■ 1 - Temp; 
NormProb :■ Temp 

end; 


norma I.src 

Programming Ins 1ght;"PoIar Normal Distribution," by 
Alain Latour. August, page 131. Also see density.src. 


Program Norma I; 

Var I : Integer; 

Y1, Y2 : Real; 

Freq : Array[0..30] of Integer; 

Procedure Initialize; 

Var I : integer; 

Begin „ „ 

For i:> 0 to 30 do Freq[i] 0 
End; 


Procedure Classify (Y: Real); 

Const MinY * -3.5; 

YRange - 7.0; 

NbClasses - 30; 

Var Temp : Integer; 

Begin 

Temp Trunc((Y-MinY)/Y Ran 9«*NbCIasses); 

If Temp < 1 then Temp :* 0 

else if Temp > NbClasses then Temp 
NbClasses; 

Freq[Temp] Freq[Temp] + 1 
End; 

Procedure NorDev (Var Y1, Y2 : Real); 

Var VI, V2, S ; Real; 

Begin 

J The "Repeat until" loop Is repeated 1.27 times 

* (continued) 
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on the average with a standard deviation 
of 0.587 (c.f. D. Knuth (1969), page 104) } 
Repeat 

VI :■ 2*Random -1; 

V2 2*Random -1; 

S Sqr(VI) + Sqr(V2) 
untiI S < 1; 

S Sqrt(-2*In(S)/$); 

Y1 V1*S; 

Y2 V2*S 

End; 

Beg i n 

Initialize; 

For i:« 1 to 5000 do 
Begin 

NorDev(Y1,Y2); 

Classify(YI); 

Classify(Y2) 

End; 

For I:«0 to 30 do 

Wrlteln(I:6,Freq[I]:12) 

End. 


Iets.src 

“Let’s C and CSD," by William Wong. August, page 267. 


/* Byte Benchmark: Eratosthenes Sieve 

02-22-86 WGW «« */ 

^define ITERATIONS 10 /* number of times to 

perform test */ 

#def!ne LOCAL 1 /* use stack for flags */ 

#define GLOBAL 0 /* use global area for flags */ 

typedef char flag ; /* different types make a 

difference */ 


#include <stdio.h> /* standard I/O definitions */ 


/*- Main Function - */ 

#deflne SIZE 7000 
#if GLOBAL 

flag flags [ SIZE + 1 ] ; /* prime number flag array */ 

#endlf 


main () 

/*- Variable definitions - */ 

/* v 

/* Note: only some register specifications will 
be used due to the */ 

/* limited number of registers available. 

Normally, the first */ 

/* items are allocated to registers. */ 

register int 1 ; /* ordered by preference */ 

register int k ; 

register int prime ; 

register int count ; 

register Int iterations ; 

#if LOCAL 

flag flags [ SIZE + 1 ] ; 

/* prime number flag array */ 

#end!f 
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/*- Show off start of execution -*/ 

printf ( "Starting Eratosthenes Sieve 
Benchmark\n\n" ) ; 

printf ( "%d iterations.\n\n", ITERATIONS ) ; 


for ( iterations * ITERATIONS ; iterations ; — 
iterations ) 

/* - 7 — Initialize Sieve Flag Array - */ 

for ( i » 0 ; 1 < SIZE ; ++ i ) 

flags [ i ] * 1 ; /* mark all as prime numbers */ 


/*- Search for Prime Numbers - */ 

for ( 1 ■ 0 /* scan for next prime number */ 

, count * 0 /* keep count of primes found */ 

; 1 < SIZE 
; ++ i 

If ( flags [ I ] !* 0 ) /* check if prime found */ 

/* - Prime found. Count it and unmark 

multiples -*/ 

++ count ; /* increment number of primes */ 

for ( prime * i + 1 + 3 

/* mark multiples as non-prime */ 

, k - 1 + prime 
/* start with first multiple */ 

; k < SIZE 
; k +* prime 

f lags [ k ] ■ 0 ; 

/* reset multiples to non-prime */ 

\ ^ 


/*- Mark end of execution - */ 

printf ( "%d prime numbers found.\n", count ) ; 
printf ( "End of Test\n\n" ) ; 

i 


/* ..«« End of Eratosthenes Sieve Benchmark *==« */ 

. pa . 

/* .... Byte Benchmark: Calculation Test 02-22-86 WGW *»«* */ 

#include <stdio.h> /* standard I/O definitions */ 


/* ===== Main Function *===* */ 

#define ITERATIONS 5000 

main () 

i 

float a, b, c ; 
int ! ; 


/*- Show start of test - */ 

printf ( "Start of Calculation Test.\n\n" ) ; 


/*- Perform test loop - */ 

[continued) 
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for ( • ■ ITERATIONS /* setup for timing loop */ 

, o - 2.71828 
. b - 3.14159 
, c * 1 

J I /* exit when end of test */ 


7*-Perform balanced set of calculations- */ 

c *- a ; /* same as c - c * a */ 

c *- b ; ' 

c /■ a ; /* same as c « c / a */ 


/*- Show end of test - */ 

prlntf ( "End of test. Accumulated error: 
%f\n\n\ c - 1 ) ; 


/* —- End of Eratosthenes Sieve Benchmark */ 

.pa 

/* «— Byte Benchmark: Write 64 kbyte file 
02-22-86 WGW ===== */ 

^include <stdio.h> /* standard I/O definitions */ 


/* ■>» Main Test Function «»= */ 

#def!ne RECORDS 512 /* records in test file */ 
^define REC_SIZE 128 /* size of records, 

total is 64kbyes */ 

main () 

Int file ; 

Int records ; 

char buffer [ REC_SIZE ] ; 

Int i ; /* buffer fill index */ 

static char filename [] * "B:TEST" ; 


/*- Show start of test - */ 

printf ( "Writing TEST file.\n\n" ) ; 

/* - Fill output buffer with recognizable 

information -*/ 

for ( 1 * 0 ; 1 < sizeof ( buffer );++!) 
buffer [ 1 ] - I ; 


/* - Write information 


*/ 


if (( file * creat ( flle_name, 0 )) > -1 ) 


/* - pile opened, try writing all the records — 


for ( records « RECORDS ; records ; — records ) 
if ( write ( file, buffer, sizeof ( buffer )) !« 
sizeof ( buffer )) 

printf ( "Write error.\n" ) ; /* show error */ 
break ; /* exit from loop */ 
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/* - Close down the file - */ 

close ( file ) ; 

\ 

e I se 

printf ( "Cannot open %s\n", file_name ) ; 


/*- Show end of test - */ 

printf ( "End of Write Test.\n\n" ) ; 

I 


/* « End of Write 64 kbyte File Benchmark ===*= */ 

.pa 

/* Byte Benchmark: Read 64 kbyte file 

02-22-86 WGW «« */ 

#1ncIude <stdio.h> /* standard I/O definitions */ 


/* «««« Main Test Function ■«»* */ 

^define RECORDS 512 /* records in test file */ 

#define REC_SIZE 128 /* size of records, 

total is 64kbyes */ 

main () 

Int file; 
int records ; 
char buffer [ REC_SIZE ] ; 
static char flle_name [] - "B:TEST" ; 


/*- Show start of test - */ 

printf ( "Reading TEST file.\n\n" ) ; 


/*- Read information - */ 

if (( file ■ open ( file_name, 0 )) > -1 ) 

/* - File opened, try reading all the records - */ 

for ( records - RECORDS ; records ; — records ) 
if ( read ( file, buffer, sizeof ( buffer )) !« 
slzeof ( buffer )) 

printf ( "Read error.\n" ) ;/* show error */ 
break ; /* exit from loop */ 

\ 


/+ -Close down the file - */ 

close ( file ) ; 

I 

e I se 

printf ( "Cannot open %s\n", filename ) ; 


/*- Show end of test -*/ 

printf ( "End of Read Test.\n\n M ) ; 

! 


/* —- End of Read 64 kbyte File Benchmark ■»=* */ 
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macapp.use 

"MacApp: An Application Framework," by Kurt J. 
Schmucker. August, page 189. 


{ The Smallest MacApp Application } 

\ Copyright 1986 by Productivity Products International, Inc.} 

{ The MAIN Program } 

PROGRAM SmallApp; 


USES 

{ This set of units are portions of the Macintosh ROM } 

MemTypes, QuickDraw, OSIntf, Toollntf, 

{ This set of units are portions of MacApp } 

UObject, UList, UMacApp, UPrinting, 

I This unit has the SmaI IApp-specific classes } 

USmalI App; 

VAR aSmallAppIicatIon: TSmaI IAppIication; } The application object - 
only one of these per application } 


BEGIN 

InitTooIbox(8); j initialize the ToolBox; 8 calls to MoreMasters { 

InitPrinting; { Initialize the print shop } 

New(aSmallAppIication); 

aSmaIlAppIication.ISmaIlAppIication; 

aSmallAppIIcation.Run; 

END. 


| *** The Unit it uses. This is typically in two separate files: one for the 
interface and one for the implementation. ***} 


Inc. } 


{ The Smallest Possible MacApp Application } 
j Copyright 1986 by Productivity Products International, 


UNIT USmalIApp; 
INTERFACE 


USES 

{ This set of units are portions of the Macintosh ROM { 

MemTypes, QuickDraw, OSIntf, Toollntf. Packlntf, 

j This set of units are portions of MacApp } 

UObject, UList, UMacApp, UPrinting; 

CONST 

myFIleType = ’MAMO’; { The file type ("MacApp MOuse’) for documents 

of this appIicat ion } 

mySignature * ’SMAP'; J The application signature of SMall 
Application } 

myWindowType = 1001; { The resource ID of the WIND resource which 

defines the windows used to 

j display the documents of this application. 

TYPE 


TSmaI IAppI I cat ion = OBJECT(TAppIication) 

{ - INITIALIZE THE APPLICATION - } 

PROCEDURE TSmaI IAppIication.ISmaI IAppIication; 

|-MAKE A DOCUMENT-} 

FUNCTION TSmallAppIicat ion.DoMakeDocument(itsCmdNumber: CmdNumber): 
TDocument; OVERRIDE; 1 
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END; 


TSmaIIDocument ■ OBJECT(TDocument) 

{ -FIELDS-} 

fSmallVIew: TSmallView; 

{ - INITIALIZE A DOCUMENT - \ 

PROCEDURE TSmaI I Document.ISmaI I Document; 

{ -MAKE A VIEW- \ 

PROCEDURE TSmalIDocument.DoMakeViews(forPrinting: BOOLEAN); OVERRIDE; 

{-MAKE A WINDOW- \ 

PROCEDURE TSmalIDocument.DoMakeWindows; OVERRIDE; 

END; 


TSmallView - OBJECT(TVIew) 

{-INITIALIZE A VIEW-} 

PROCEDURE TSmalIView.ISmalIView(itsSmaIIDocument: TSmalIDocument); 

{-RENDER THE IMAGE-} 

PROCEDURE TSmalIVIew.Draw(area: Rect); OVERRIDE; 

END; 


IMPLEMENTATION 


} Copyright 1985 by Productivity Products International, Inc.} 
{ USmallApp Implementation } 

* . 

*****************************************************************************( 

i t 

***************************************************************************** j 

METHODS FOR ALL THE SMALLAPP CLASSES 


Note that methods are grouped by class and that the order of methods in 
any class is the following } 

(by convention only, since Object Pascal forces no order): } 


(1) the Initialization method, if any, } 

(2) the Inspect method - a private debugging method, if needed } 

(3) the Free method, if overridden, and} 

(4) the remaining methods in alphabetical order. } 


************************************************************************* } 
************************************************************************* } 


| ik************* TSmaI IAppIication Methods ********************* } 

PROCEDURE TSmalIAppI I cat ion.ISmaI IAppIicat ion; 

BEGIN 

SELF.IAppIication(myFileType); 

END; 

j-MAKE AND INITIALIZE A DOCUMENT-} 

FUNCTION TSmaI I App I 1 cation.DoMakeDocument(11sCmdNumber: CmdNumber): 

TDocument; OVERRIDE; 

VAR aSmalIDocument:TSmaIIDocument; 

[continued) 
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BEGIN 

NEW(aSmalIDocument); 

aSmalI Document.ISmaIIDocument; 

DoMakeDocument :■ aSmaI I Document; 

END; 


{ *************** TSmaIIDocument Methods ********************** } 

PROCEDURE TSmaI I Document.ISmaI I Document; 

BEGIN 

SELF.IDocument(myFI IeType, mySignature, TRUE, FALSE); 

END; 


{ - MAKE AND INITIALIZE ALL THE NECESSARY VIEWS - \ 

PROCEDURE TSmaI I Document.DoMakeViews(forPrInting: BOOLEAN); OVERRIDE* 
VAR smallView: TSmallView; 

BEGIN 

NEW(smalIView); 

smaIIView.ISmalIView(SELF); 

SELF.fSmaI IVIew :« smallView; 

END; 


|-MAKE ALL THE NECESSARY WINDOWS-} 

PROCEDURE TSmaI I Document.DoMakeWindows; OVERRIDE; 

VAR aWindow: TWindow; 

BEGIN 

aWindow ;■ NewSimp IeWindow(myWindowType, FALSE { NOT a DialogWindowf, 

kWantHScrolI Bar, kWantVScrolI Bar, 

SELF.fSmaIIView); 

END; 


| ************************** TSmallVie 1 

PROCEDURE TSmaIIView.ISmalIView(itsSma 
VAR viewRect: Rect; 

aStdHandIer: TStdPrIntHandIer; 

BEGIN 

SetRect(viewRect, 0, 0, 500, 500); 
IV!ew(NIL, 

itsSmaI I Document, 
viewRect, 
sizeFIxed, 

sizeFlxed, 

FALSE, 
hlOff); 


Methods ************************ | 
I Document: TSmaI I Document); 


! This view has no parent view, 
and shows a smaI I Document, 

I In a 500 x 500 rectangle, 
that does not change if the 
frame Is changed horizontally, 
or vertically, 

i and can't make selections 

and doesn't highlight when the 
window is inactive. \ 


New(aStdHandIer); 

aStdHandIer.IStdPrintHandIer(SELF, FALSE); { The second parameter, 
ItsSquareDots. is FALSE since this application does not mix text 
and graphics. Slightly higher resolution is available with this 
setting. \ 

END; 


}-RENDER THE IMAGE-} 

PROCEDURE TSmaI IView.Draw(area: Rect); OVERRIDE; 

FUNCTION MakeRect(top, left, bottom, right: INTEGER): Rect; 
VAR r: Rect; 

BEGIN 

SetRect(r, left, top, right, bottom); 

MakeRect :* r; 

END; 
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BEGIN 


PenNorma1; 
PaintOval 1 

'MakeRect1 

[74, 72. 139, 127); 

1; | 

EraseOva1( 

[MakeRect1 

[84, 74, 138. 125); 

1 ; | 

FrameOva1 ( 

'MakeRect1 

[109, 84, 129, 115; 

1 ); 

EraseRect1 

[MakeRect1 

[109, 84, 123. 115] 

i): 

FrameOva11 

'MakeRect1 

[98, 87, 107, 96)); 


FrameOva11 

[MakeRect1 

98. 104, 107, 113)); { 

PaintOva1 \ 

[MakeRect1 

[101, 90. 104, 93)] 

l; 1 

Pa IntOva11 

[MakeRect1 

[101, 107, 104, 110)); \ 

PaintOval1 

[MakeRect1 

fill, 97, 117, 103)); I 

PaintOva11 

[MakeRect1 

53, 52, 91. 90)); 


PaintOval(MakeRect1 

[53. 110, 91, 148)); J 


Outline of the mouse head 
Outline of the mouse face 
Mouse mouth (part 1 of 2) 
Mouse mouth (part 2 of 2) 
Left eye \ 

Right eye } 

Left pupiI \ 

Right pupiI \ 

Nose \ 

Left ear \ 

Right ear } 


FrameRect(MakeRect(20, 20, 170, 180)); 


A bounding rectangle \ 


END; 


END. 


mapper.bas 

"Similarity Mapping," by Rob Spencer. August, page 85. 


• similarity mapping 

• I Robin W. Spencer 

GOSUB Initialize 
GOSUB SetMenus 
GOSUB InputData 
GOSUB ShowTabIe 
GOSUB InitializeMap 
GOSUB ShowMap 
GOSUB RefineMap 
GOSUB ShowMap 

WHILE NOT AI I Done 

GOSUB WaitForMenu 
GOSUB HandleMenu 
GOSUB ShowMap 

WEND 

GOSUB ShowQuitBox 

IF ButtonId-1 THEN RUN ELSE SYSTEM 


subroutines 


Initialize: 

DEFINT I-n 

WINDOW 1,,(0,20)-(512,340),3 
CALL TEXTFONT(0):CALL TEXTSIZE(12) 

CLS 

True ■ -1 : Fa Ise ■ 0 
AlIDone«FaIse 
MaxlteratIons«20 
R - .15 : Criter ion ■ .2 

xleft - 0 : xrlght - 512 * screen window in pixels 

ytop - 20 ; ybottom ■ 320 

xcenter ■ (xleft + xrlghO/2 
ycenter * (ytop + ybottom;/2 
DEF FNPx(x) - x*Scale + xcenter 
DEF FNPy(y) ■ y*Scale + ycenter 
RETURN 

SetMenus: 

MENU 1,0,1,"Control" 

MENU 1,1,1,"Change Map" 
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MENU 1,2,1,"Show Table" 
MENU 1,3,0,"-" 

MENU 1,4,1,"Quit" 


MENU 2,0,0,"" 
MENU 3,0,0,"" 
MENU 4,0,0,"" 
MENU 5,0,0,"" 
RETURN 


InputData: 

PRINT:PRINT" Select the Input file:" 
InputFI Ie$ - FILES$(1,"TEXT") 

OPEN InputF!Ie$ FOR INPUT AS #1 


INPUT#1, Title$ 

INPUT#1, NumPoInts 

NumPalrs - NumPoInts*(NumPoints-1)/2 


abel$(Nillnp|int8) 0,nt8),X(NUmF,0intS),y(NUn ’ POints) ’ Dx(Nu,nPoints),Dy(NumPoints )' 1 - 

FOR i-1 TO NumPoints 
INPUT# 1, Labe I $0 ) 

NEXT I 

FOR i-2 TO NumPoints 


FOR J-1 TO i-1 

INPUT#1, d(i.J) 
<J(j.i)-d(i.j) 

IF d(l,J)<0 THEN 
NEXT J 
NEXT i 
CLOSE#1 
RETURN 


NumPaIrs 


NumPairs-1 


Initial IzeMap: 
dmax-0 

find the two most distant points 
FOR I«1 TO NumPoints-1 

FOR j»I+1 TO NumPoints 

IF d(I,J)>dmax THEN dmax-d(l,j) 
NEXT J 
NEXT I 


J1-I : J2-J 


xHO- 0 ; y(J1 )-0 

x(j2)- dmax : y(J2)-0 

Scale - .6*(xright-xleft)/dmax * scale in pixels per distance unit 
dnext«0 

find the third most distant point 
FOR I«1 TO NumPoints 

IF i-jl OR I-J2 THEN FirstLoop 
deIta-d(I.j1)+d(I,J2)-d(j1,j2) 

IF de I todnext THEN dnext-deI to:j3=i 
FirstLoop: 

NEXT I 


x (J3)*d(J1,J3)-dnext/2 
y(j3)-SQR(d(j1.J3)-2-x(J3)-2) 


FOR 1-1 TO NumPoints 
Initialize all the other points 

IF I-J1 OR i-J2 OR i-J3 THEN SecondLoop 
x(|)-(d(II,I)"2-d(j2.ir2+dmox-2)/(2*dmox) 
y( I )-SQR(ABS(d(j 1,1 )'"2-x( I)*2)) 

IF (x(!)-x(J3))*2+y(J3)~2 < d(j3,l)~2 THEN y(i)= 
SecondLoop: 

NEXT I 


-yo: 


FOR I«1 TO NumPoints 
the coordinate set 

x(I) ■ x(I) - dmax/2 
NEXT I 
RETURN 


center 


RefineMap: 

Converged - False : Iteration « 1 : OldError - 10000 
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WHILE NOT AIIDone AND NOT Converged AND Iteration < Maxiterations 
GOSUB IterateMap 

IF MENU(0)>0 THEN GOSUB HandleMenu 
GOSUB ShowMap 

IF ABS(PercentError - OldError) < Criterion THEN Converged * True 
IF PercentError > OldError THEN R * .7*R 
OldError « PercentError 
Iteration * Iteration + 1 

WEND 

Title$ - Title$ + " (final) 1 ' 

RETURN 

IterateMap: 

SumError*0 

FOR i-1 TO NumPoints 
Dx(i)«0 : Dy(i)»0 
NEXT i 

FOR i-1 TO NumPoints-1 * calculate the changes Dx() and Dy() 

FOR j«i + 1 TO NumPoints 

IF d(i,j)<0 THEN InnerLoop * allow for unknown 

distances 

dcalc«SQR((x(i)-x(j))-2 + (y(i)-y(j))*2) 

IF dcalc=0 THEN InnerLoop 

delta « (d(I.j)/dcaIc-1)*(x(j)-x(i)) 

Dx(i)«Dx(i)-deIta 
Dx(j)»Dx(j)+deIta 

delta * (d(i,j)/dcaIc-1)*(y(j)-y(i)) 

Dy(i)«Dy(i)-delta 
Dy(j)*Dy(J)+deIta 

SumError = SumError + ((dcaIc-d(i.j))/d(i,j))^2 
InnerLoop: 

NEXT j 
NEXT I 

FOR i-1 TO NumPoints ' make the changes to the points 

x(i)»x(i) + Dx(1)*R 
y(i)-y(i) + Dy(i)*R 
NEXT i 

PercentError ■ 100^SQR(SumError/NumPairs) 

RETURN 

WaitForMenu: 

WHILE MENU(0)«0 

WEND 

RETURN 

Hand I©Menu: 

Itemld - MENU(1) 

IF Itemld - 4 THEN AIIDone-True : RETURN 
ON Itemld GOSUB ShowPaneI.ShowTabIe 
MENU 1,0,1 
RETURN 

ShowTabIe: 

CALL TEXTFONT(4):CALL TEXTSIZE(9): CALL TEXTMODE(1) 

CLS 

PRINT:PRINT" Distance table for ";Title$ 

IF Iterations THEN GOSUB SetFormat ELSE Formats*" #####*' 

PRINT 

FOR i-1 TO NumPoints 

PRINT TAB(12+6*1);I; 

NEXT i 

PRINT:PRINT 

Sum»0 

FOR 1-1 TO NumPoInt* 

PRINT USING"##) \ \";1,Lobel$(i); 

FOR J-1 TO NumPoints 

IF J<l THEN d-d(I.J) ELSE d-0 

IF J>l AND Iterotlon>0 THEN d-SQR((x(I)-x(j))~2 + (y(i)-y(J))~2) 

IF J>l AND d(I,J)>0 THEN Sum-Sum + (d-d(i,j)) A 2 

IF d>0 THEN PRINT USING Formot$;d; : ELSE PRINT SPACE$(6); 

NEXT J 
PRINT 

[continued) 
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NEXT I 

PRINT:PRINT TAB(40);"observed \ caIcuIated":PRINT 
IF IteratIon>0 THEN PRINT USING" Average error - "+Format$+" 
SQR(Sum/NumPaIrs).PercentError 

BUTTON 1,1."Ok",(400,280)-(480,310) 

GOSUB GetButton 
BUTTON CLOSE 1 
RETURN 

SetFormat: 

I ength-INT(.43*L0G(ABS(dmax)) ♦ 1.5) 

Format$-" "♦STRING$(Iength,"#")+"." 

WHILE LEN(Format$)<6 
Format$-Format$+"#" 

WEND 

RETURN 

ShowMap: 

Cls 

PRINT TItle$ 

PRINT USING" Iteration ##";Iteration 

IF Iterations THEN PRINT USING" ###.# % error";PercentError 
FOR 1-1 TO NumPoInts 

CALL MOVETO(FNPx(x(i)),FNPy(y(I))) 

PRINT "E \-LabelS(i); 

NEXT i 
RETURN 

ShowPaneI: 

WINDOW 2,,(3,24)-(509,48),-4 
CALL TEXTFONT(0):CALL TEXTSI2E(12) 

BUTTON 1,1, "rotate",(2.2)-(52,22) 

EDIT FIELD 1,"0",(56,4)-(88,19) 

RESTORE ShowPaneI 
x-94 

FOR i-2 TO 8 
READ IdS 

BUTTON I,1,IdS>(x,2)-(x+52,22) 
x-x+54 
NEXT I 

DATA expand,shrInk,fI Ip,up,down,Ieft,rIght 
BUTTON 9,1,"Ok",(x.2)-(x+30.22) 

WHILE DIALOG(0)<>0:WEND * flush pending dialog events 
Done-Fa Ise 
WHILE NOT Done 

GOSUB GetButton 
GOSUB MoveMap 
WINDOW OUTPUT 1 
GOSUB ShowMap 
WINDOW OUTPUT 2 

WEND 

WINDOW CLOSE 2 
RETURN 


GetButton: 

Event-0 
WHILE Eventol 

Event - DIALOG(0) 

WEND 


Buttonld-DIALOG(I) 

RETURN 

MoveMap: 

IF ButtonId-1 THEN 
IF ButtonId-2 THEN 
IF ButtonId-3 THEN 
IF ButtonId«4 THEN 
IF ButtonId-5 THEN 
IF ButtonId-6 THEN 
IF ButtonId-7 THEN 
IF ButtonId=8 THEN 
IF ButtonId-9 THEN 
RETURN 


GOSUB RotateMap 
Scale-Scale*!.1 
Sea Ie«ScaI e/1.1 
GOSUB FlipMap 
ycenter » ycenter - 5 
ycenter - ycenter + 5 
xcenter « xcenter - 5 
xcenter « xcenter + 5 
Done-True 


(###.# %)- 
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RotateMap: 

theta - VAL(EDIT$(1)) 
theta-theta*3.14159/180 
s I ne*SIN(theta) : cos Ine«COS(theta) 
FOR i*1 TO NumPoInts 

xt - xHHcosine - yfH*sine 
y(0* y(i)*cosine + x(i)*sine 
x(l)* xt 
NEXT i 
RETURN 


FI 


ipMap: 

FOR 1-1 TO NumPoInts 
x(i)« -x(i) 


NEXT I 
RETURN 


ShowQuitBox: 

WINDOW 2, "",(150,105)-(360,160),-2 
BUTTON 1,1,"Run Again",(10,10)-(100,40) 
BUTTON 2,1,"Quit",(110,10)-(200,40 ) 
GOSUB GetButton 
WINDOW CLOSE 2 
CLS 

RETURN 


micros.dat 

"Similarity Mapping," by Rob Spencer. August, page 85. 


"Cluster Example" 
12 


Ace,App1e 

lie,Atar1 

800,Comm 

64,Compaq,IBM PC.Kaypro II 

.Osborne 

I.TI 99/4A.TRS Color/80- 

2.66 








3.79 , 

2.61 







3.94 . 

2.82 , 

1.17 






5.41 , 

5.46 , 

6.79 , 

6.34 





4.15 , 

4.20 , 

5.23 , 

4.82 . 

3.26 




2.49 , 

4.07 , 

4.87 , 

4.98 , 

5.33 , 5.19 




2.43 , 

3.57 , 

4.37 , 

4.47 , 

5.01 , 4.85 , 

0.99 



4.33 , 

3.34 , 

1.10 , 

1.88 , 

7.41 , 5.66 , 

5.28 , 

4.80 


4.18 , 

3.15 , 

1.02 , 

1.85 , 

7.30 , 5.52 , 

5.17 , 

4.69 , 

0.24 

2.08 , 

2.12 , 

3.42 , 

3.33 , 

4.70 , 3.27 , 

3.63 , 

3.03 , 

3.99 . 3.84 

4.69 , 

3.80 , 

1.83 , 

1.96 , 

7.36 , 5.46 , 

5.58 , 

5.13 , 

1.13 , 1.19 


citles.dat 

"Similarity Mapping," by Rob Spencer. August, page 85. 


"Intercity distances" 

9 

Boston,NY,DC,Miami.Chicago 
Seattle,SF,LA,Denver 
206 

429. 233 


1504,1308,1075 
963, 802, 671,1329 
2976,2815,2684,3273,2013 
3095,2934,2799,3053,2142, 808 
2979,2786.2631,2687,2054.1131, 379 
1949,1771,1616,2037, 996,1307,1235,1059 


cytoc.dat 

"Similarity Mapping," by Rob Spencer. August, page 85. 


"Cytochrome C sequence distances" 
12 

human,monkey,dog,horse,donkey 
pig,rabbit.kangaroo,duck 
pigeon,chicken,turtle 
1 

13,12 


17,16,10 
16,15, 8, 1 

13.12, 4, 5, 4 

12 . 11 , 6 , 11 , 10 , 6 

12.13, 7,11,12, 7, 7 


(continued) 
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18,17,14,16.15,13.11,15, 3. 4 
19,18,13,16,15,13.11,14, 7, 8. 8 


17,16,12,16,15,13,10,14 
16,15,12,16,15.13, 8,14, 3 


factsum.bas 

Mathematical RecreatIons:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


10 REM-< Sum-of-FactorI a Is Routine >— 

20 REM-< Bob Kurosaka >— 

30 REM 


40 DIM A(10),B(100),F(10) :REM A()=digits, B()=sums, 
F()=factor la Is. 

50 DATA 1,1,2,6,24,120,720,5040,40320,362880 
60 FOR J»1 TO 10 
70 READ F(J) 

80 NEXT J 
90 CLS 

100 PRINT "Program generates factorial sum 
sequences." 

110 PRINT 

120 PRINT "Lower limit, upper limit 
130 INPUT LL, UL 
140 LL=ABS(INT(LL)) 

150 UL«ABS(INT(UL)) 

160 REM 

170 FOR N-LL TO UL :REM Sequences for each no. 

LL to NN 


180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 

290 

300 

310 

320 

330 

340 

350 

360 

370 

380 

390 

400 

410 

420 

430 

440 

450 

460 

470 


SP-0 


:REM SP counts the steps 
before a cycle 
:REM Make the first term-N 
:REM Print the current term 
:REM Make a copy of latest term 


B(SP)=N 
PRINT B(SP); 

M»B(SP) 

REM 

REM Break up the term into its component digits 
:REM D ■ no. 

REM T - no. 


D-1 

T«INT(M/10) 

A(D)=M-10*T 


of digits 
of "Tens" in M 
REM Store rightmost digit 
In array A 
D-D+1: M=T: GOTO 250 


IF T<>0 THEN 
REM 

REM Calculate the sum of the factorials of 
the digits in A() 


SUM-0 

FOR 1-1 TO D 
SUM-SUM+F(A(I ) + 1) 
NEXT I 


REM See if sum has occurred already. 
1=0 

WHILE B(I)<>SUM AND I<»SP 
1 = 1+1 


WEND 

IF B(I)=SUM AND I<«SP THEN 440 
SP=SP+1 :REM one more step 

B(SP)«SUM :REM Store SUM in array B 

GOTO 200 
REM 

PRINT SUM; "* loops to step "; I :REM Show 

where it repeats 

PRINT 

NEXT N 

END 
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factsum.run 

Mathematical Recreations:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


Program generates factorial sum sequences. 
Lower limit, upper limit ? 24, 27 


24 26 722 5044 

loops to step 4 

169 363601 

1454 

169 * 

25 122 5 120 4 
1454 169 * loops to 

24 26 722 

step 9 

5044 

169 363601 

26 722 5044 169 

to step 3 

363601 1454 

169 

♦ loops 

27 5042 147 5065 

961 363601 

1454 

169 


363601 * loops to step 5 
Ok 


cubesum.bas 

Mathematical Recreations:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


10 REM-< Sum-of-Cubes Routine >- 

20 REM-< Bob Kurosaka >- 

30 REM 


40 DIM A(10),B(100) :REM A() holds digits, 

B() holds sums. 

50 CLS 


60 PRINT "Program generates sequences of 
cube-sums." 

70 PRINT 

80 PRINT "Lower limit, upper limit 
90 INPUT LL, UL 
100 LL-ABS(INT(LL)) 

110 UL«ABS(INT(UL)) 

120 REM 

130 FOR N-LL TO UL :REM Sequences for each 

no. LL to NN 


140 SP-0 

150 B(SP)«N 
160 PRINT B(SP); 

170 M-B(SP) 


:REM SP counts the steps 
before a cycle 
:REM Make the first term-N 
:REM Print the current 
term 

:REM Make a copy of 
latest term 


180 REM 

190 REM Break up the term into its 
component digits 

200 D»1 :REM D - no. of digits 

210 T-INT(M/10) :REM T - no. of "Tens" in M 

220 A(D)«M-10*T :REM Store rightmost digit in array 

230 IF T<>0 THEN D-D+1: M-T: GOTO 210 

240 REM 


250 REM Calculate the sum of the cubes of the 
digits In A() 

260 SUM-0 

270 FOR 1-1 TO D 

280 SUM«SUM+A(I )*A(I)*A(I) 

290 NEXT I 

300 REM See If sum has occurred already. 

310 1-0 

320 WHILE B(I)<>SUM AND I<-SP 
330 I-I+1 
340 WEND 

350 IF B(I)«SUM AND I<-SP THEN 400 


A 


(continued) 
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360 SP-SP+1 :REM one more step 

370 B(SP)»SUM :REM Store SUM In array B 
380 GOTO 160 
390 REM 

400 PRINT SUM; "* loops to step I :REM Show 
where It repeats 
410 NEXT N 
420 END 


cubesum.run 

Mathematical RecreatIons:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


Program generates sequences of cube-sums. 





23 

35 

152 

134 

92 

737 713 371 

Lower 11 

imit, upper 

1imit ? 21, 25 

loops 

to step 7 



21 9 

729 1080 

513 153 153 * 

24 

72 

351 

153 

153 

* loops to step 

loops 

to step 5 


25 

133 

55 

250 

133 

♦ loops to step 

22 16 

217 352 

160 217 * loops to step 2 

Ok 







palind.bas 

Mathematical RecreatIons:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


10 REM-< Palindromic Sums Routine >- 

20 REM-< Bob Kurosaka >- 

30 REM 

40 SP$«" " :REM One space Inside quotes 

50 D$«"0123456789" 

60 YES-(I-I) 

70 DIM A(100) :REM A() holds the the digits. 

80 CLS 

90 PRINT "Program generates sequences that end 
In pal Indromes." 

100 PRINT 

110 PRINT "Lower limit (>10) and upper limit "; 

120 INPUT LL, UL 
130 LL=ABS(INT(LL)) 

140 UL-ABS(INT(UL); 

150 IF LL<10 THEN 110 
160 FOR N-LL TO UL 

170 SP-0 :REM SP counts the steps before a cycle 
180 REM 

190 REM Break up the term Into Its component digits 
200 M-N :REM Make a copy of latest term 

210 D»1 :REM D - no. of digits 

220 T»INT(M/10) :REM T - no. of "Tens" in M 
230 A(D)«M-10*T :REM Store rightmost digit in 
array A 

240 IF T<>0 THEN D-D+1: M=T: GOTO 220 

250 ODD-ABS ((I NT (D/2) <>D/2 ) ) :REM Even or odd 

no. of digits? 

260 REM 

270 REM Print the latest term 
280 FOR I-D TO 1 STEP -1 
290 PRINT MID$(D$,A(I)+1,1); 

300 NEXT I 
310 PRINT SP$; 

320 REM 

330 REM Check for palindrome 
340 FOR 1-1 TO D/2 
350 PL«(A(I)*A(D-I+1)) 

360 IF NOT PL THEN I-D/2 :REM Exit from loop if 
no. Is not a pa I. 

370 NEXT I 

380 IF PL THEN 580 

390 REM 

400 REM Add each digit to its reverse Image 
counterpart 
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410 FOR 1-1 TO D/2+ODD 
420 A(I)»A(I)+A(D-I+1) 

430 A(D-I+1)-A(I) 

440 NEXT I 

450 REM Check for carry 
460 FOR 1-1 TO D 
470 IF A(I)<10 THEN 500 
480 A(I)-A(I)-10 
490 A(I + 1)-A(I+1)+1 
500 NEXT I 

510 IF A(D+1)-0 THEN 540 
520 D-D+1 

530 ODD-ABS((INT(D/2)<>D/2)) 

540 SP-SP+1 
550 GOTO 280 
560 REM 

570 REM Indicate that a cycle has been found 

580 PRINT "* at step M ; SP 

590 FOR 1-1 TO D 

600 A(I)=0 

610 NEXT I 

620 NEXT N 

630 END 


palind.run 

Mathematical Recreations:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


Program generates sequences that end in 
pa Iindromes. 

Lower limit (>10) and upper limit ? 75. 80 

75 132 363 * at step 2 

76 143 484 * at step 2 

77 * at step 0 

78 165 726 1353 4884 * at step 4 


powser.bas 

Mathematical Recreations:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


79 176 847 1595 7546 14003 44044 * at 
step 6 

80 88 * at step 1 
Ok 


10 REM-< Delete and Add Routine >- 

20 REM-< Bob Kurosaka >- 

30 REM 

40 N-50 :REM N-number of integers in starting 

sequence. 


50 DIM SF$(3), A(N) :REM SF$() holds suffixes, 

A() holds sequence. 

60 DATA nd, rd, th 

70 FOR J-1 TO 3: READ SF$(J): NEXT J 
80 REM 
90 CLS 

100 PRINT "Program uses a deIete-and-add process" 
110 PRINT "to generate i^p for 1-1 to ";N; "/ p." 
120 PRINT: INPUT "Enter a value for p (power)"; P 
130 P-ABS(INT(P)) 

140 IF P<2 THEN 100 
150 REM 

160 PRINT: PRINT "Starting sequence:" 

170 FOR 1-1 TO N 
180 A(I)»I 
190 PRINT I; 

200 NEXT I 
210 PRINT 
220 REM 

230 FOR R-P TO 2 STEP-1 


{continued) 
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240 DC-0 :REM Counts the number 

of terms deleted. 

250 FOR J-R TO N STEP R :REM Delete every Jth term 

260 A(J)»0 

270 DC-DC+1 

280 NEXT J 

290 REM 

300 REM -< Print deleted orroy >- 

310 WSF«SGN(R-3)+2 :REM Select suffix 

320 PRINT: PRINT "Delete every R; SF$(WSF); 

M term:*' 

330 FOR 1-1 TO N 

340 IF A(I)<>0 THEN PRINT A(I); ELSE PRINT "*"; 

350 NEXT I 
360 REM 

370 REM -< Compute Partial Sums >- 

380 K-1 

390 FOR J-2 TO N-DC :REM There will be N-DC 

valid numbers. 

400 K-K+1 :REM K points to next 

term to be added. 

410 IF A(K)«0 THEN K-K+1 :REM Skip zero (deleted) 

terms. 

420 A(J)«A(J-1)+A(K) :REM Calculate partial sum. 


430 NEXT J 

440 N-N-DC :REM Revise the number of valid 
terms In A(). 

450 REM 

460 REM -< Print Partial Sums >- 


470 PRINT: PRINT: PRINT "Partial sums:" 
480 FOR 1-1 TO N 
490 PRINT A(I); 

500 NEXT I 
510 PRINT 
520 NEXT R 
530 END 


powser.run 

Mathematical Recreations:"Number Games," by Robert T. 
Kurosaka. August, page 333. 


Program uses a deIete-and-add process 
to generate i^p for i-1 to 50 / p. 


Enter a value for p (power)? 4 
Starting sequence: 


1 

2 3 

4 

5 

6 

7 8 

9 

10 

11 

12 

13 

14 

15 

16 

17 

18 

19 

20 

21 

22 

23 

24 

25 

26 

27 

28 

29 

30 

31 

32 

33 

34 

35 

36 

37 

38 

39 

40 

41 

42 

43 

44 

45 

46 

47 

48 

49 

50 








De 1 < 

jte every 

4 

th 

term: 






1 

2 3 

* 5 

6 

7 

* 9 

10 

11 : 

* 13 

14 

15 ■ 

17 

18 

19 * 21 

22 

23 * 

25 

26 

27 

* 29 30 

31 

* 33 

34 

35 

* 

37 38 39 * 

41 

42 

43 * 


46 47 * 49 50 

Partial sums: 


1 3 

6 

11 

17 24 

33 

43 

54 67 81 

96 

113 

131 

150 

171 

193 

216 

241 267 

294 

323 

353 

384 

417 

451 

486 

523 561 

600 641 

683 

726 

771 

817 

864 

913 

963 



Delete every 3 rd term: 

1 3*11 17 * 33 43 * 67 81 * 113 131 * 

171 193 * 241 267 * 323 353 * 417 451 * 

523 561 * 641 683 * 771 817 * 913 963 

Partial sums: 

1 4 15 32 65 108 175 256 369 500 

671 864 1105 1372 1695 2048 2465 2916 

3439 4000 4641 5324 6095 6912 7825 8788 
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Delete every 2 nd term: 

1 * 15 * 65 * 175 * 369 * 671 * 1105 * 1695 * 
2465 * 3439 * 4641 * 6095 * 7825 * 

Partial sums: 

1 16 81 256 625 1296 2401 4096 6561 

10000 14641 20736 28561 

Ok 


readfort.me 

"Object-Oriented FORTH," by Dick Pountain, August, page 
227. Also see types.doc. 


A minor addition concerning error handling must be 
made to the TYPES.SCR or TYPES.DOC code. In screen 2 
of the source code, the system sets up a third 
stack called OSTACK, which incorporates no checking 
for underflow or overflow. In certain circumstances, 
overflow could occur. If you are debugging a new 
type and an operation crashes in such a way that 
FORTH executes an ABORT, OPOP wiI I never be reached 
and a stray item will be left on the OSTACK. If 
repeated enough, this could overflow the stack. 

To solve the problem, you need to modify ABORT 
to reset OSTACK. The way to do this depends on your 
FORTH system. 

This Is the actual code that you'll need: 

: ORESET OSTACK DUP 16 ♦ SWAP ! ; ( Reset 

OSTACK to empty) 

: MYABORT ORESET ABORT ; 

To replace ABORT by MYABORT, a variety of routes 
are open. In a good professional FORTH system, ABORT 
will be vectored through a variable, or other known 
memory location, to let you set up custom error 
handling. The variable might be called, for example, 
UABORT, and you would use: 

* MYABORT UABORT ! 

You need to find out how It's done in your own 
system. 

If your system does not provide vectored 
execution for ABORT, then you need to check out the 
internals of the definition of your ABORT, 
perferably by using a decompiler, but at worst by 
studying its hex dump. 

At some point, usually at the very end, ABORT 
calls QUIT. If you can find the address of this call 
to QUIT (let's call it ZZZZ), then instead of 
MYABORT you can define: 

: MYQUIT ORESET QUIT ; 

and then do a dirty patch of MYQUIT into this 
address: 

' MYQUIT ZZZZ l 

Test the redefined ABORT carefully before 
proceeding, as a flaky ABORT is pretty explosive in 
effect. 


types.doc 

"Object-Oriented FORTH," by Dick Pountain, August, page 
227. Also see readfort.me. 


Screen # 1 

0 ( Type definitions 
1 

2 ( Working variables for object compiler) 

3 VARIABLE SIZE ( Holds storage size of type) 


( continued ) 
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4 VARIABLE INHERIT 

5 VARIABLE OPS 

6 VARIABLE STASH 

7 VARIABLE PUBLIC 

8 VARIABLE LASTLOCAL 

9 VARIABLE IN.TYPE.DEF? 

10 VARIABLE VAL ( 


( Holds address of Inherited 
ops vocab) 

( Holds address of end of 
ops vocabulary) 

( Temporary store for current 
vocabuI ary) 

( Holds link to ordinary 
dictionary) 

( Holds address of last word 
In type) 

( Flag; are we In a type 
definition?) 

Flag; has a VAL Index 
been declared?) 


11 

12 0 CONSTANT FALSE FALSE NOT CONSTANT TRUE 
( For readabiIIty) 

13 


14 ( I refuse to use THEN, which Is a syntactic 

abomination!!) 

15 ; ENDIF [COMPILE] THEN ; IMMEDIATE —> 


Screen # 2 

0 ( Type definitions 
1 

2 ( Make a third stack to hold current object's 

address ; its size 

3 determines how deeply type definitions 
may be compounded) 

4 CREATE OSTACK HERE 16 + , 16 ALLOT 

5 

6 ( Push parameter stack to object stack) 

7 : OPUSH OSTACK -2 OVER +! @ ! ; ( n - ) 

8 

9 ( Pop object stack and discard) 

10 : OPOP 2 OSTACK +! ; ( - ) 

11 

12 ( Copy top of object stack and ADD to top 

of parameter stack) 

13 ; OCOP+ OSTACK © e + ; ( n - n ) 

14 

15 — > 


Screen # 3 

0 ( Type definitions 
1 

2 ( Compile offset into instance variable and 
bump the total) 

OFFSET SIZE @ 2 + , SIZE +! 


( size- ) 


( Purely for brevity) 

: COMPLIT [COMPILE] LITERAL 


8 ( Compile code to add offset into object body) 

9 : COMPILE.ADDOFF COMPLIT COMPILE OCOP+ ; 


( size- ) 


10 

11 

( Create a new 

instance variable of 

12 

: VAR CREATE 

OFFSET 

13 


IMMEDIATE 

14 

DOES> 

® COMPILE.ADDOFF ; 

15 


—> 


Screen # 4 

0 ( Type definitions 
1 

( Open a type declaration) 

- LATEST PUBLIC ! 

CREATE 

HERE LASTLOCAL ! 

0 SIZE ! 

TRUE IN.TYPE.DEF? ! 
FALSE INHERIT ! 


TYPE> 


NFA of last public wor 
Make a header) 

Store its PFA) 

Initial I sat ions) 


2 

3 

4 

5 

6 

7 

8 
9 

10 ( Mark boundary which hides the 

Instance variables) 

11 : OPS> HERE ( Address following 

last VAR) 


272 BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 




August 


12 

0 C, 

13 

LATEST , 

14 

DUP CONTEXT © 

15 

N>LINK OPS ! ; 


( Make dummy name field) 

( Link field points to 
last VAR) 

( Let Forth know about 
dummy word) 

( Save its LFA) —> 


Screen # 5 

0 ( Type definitions 
1 

2 ( Save current vocabulary; set operations 

vocabuI ary) 

3 ; UNLOCK CONTEXT © DUP © STASH ! ! ; 

( key- ) 

4 

5 ( Restore current vocabulary) 

6 ; LOCK STASH © CONTEXT © ! ; 

7 

8 ( Look up an operation In its type vocabulary) 

( key-CFA) 

9 : FINDOP BL WORD SWAP ( Get operation name 

10 UNLOCK FIND LOCK ( Find it) 

11 0= ABORT" unrecognised operator " ; 

( Abort if not found) 


12 

13 

14 


) 


Screen # 6 

0 ( Type definitions 
1 

2 ( Execute an operation immediately, if found) 

3 : DO.OP SWAP OPUSH FINDOP EXECUTE OPOP ; 

( addr key - ?) 

4 

5 ( Compile operation calling sequence) 

6 : COMPILE.CALL COMPILE OPUSH , COMPILE OPOP ; 

( CFA- ) 

7 

8 ( Look-up operation and compile it) 

9 : COMPILE.OP FINDOP SWAP COMPLIT 

( addr key- ) 

10 COMPILE.CALL ; 

11 

12 ( Fetch size field contents from instance 

variable or type) 

13 ; SZ© 2 + © ; ( addr - size) 

14 

15 : SELF ; ( Optional; used for readability only) —> 
Screen § 7 

0 ( Type definitions 
1 

2 ( Create an instance variable of a predefined type) 

( addr-) 

3 : MAKE.STRUCTVAR DUP SZ® ( get size) 

4 SWAP © ( fiat 

5 CREATE . OFFSET ( Store key and size) 

6 IMMEDIATE 

7 DOES> DUP @ SWAP SZ® 2 - ( Get key and offset) 

8 COMPILE.ADDOFF ( Compile code_ ) 

9 FINDOP ( to treat as. ) 

10 COMPILE.CALL ; ( an object. ) 

11 

12 ( Compile or interpret an operation 

according to state) 

13 : DO.OR.COMP STATE © IF COMPILE.OP 

( addr key- ) 

14 ELSE DO.OP 

15 ENDIF ; —> 

Screen # 8 

0 ( Type definitions 
1 


[continued) 
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2 ( Allot space Initialised to zeroes) 

3 : ALLOTZ DUP HERE SWAP 0 FILL ALLOT ; ( n - ) 

4 

5 ( Execute an operation called INIT if 

there is one) 

6 : INITIALIZE SWAP OPUSH 

7 UNLOCK LIT” INIT" FIND LOCK 

8 IF EXECUTE ELSE DROP ENDIF OPOP ; 

9 

10 ( Create a new Instance of a type) 

( addr ) 

11 : MAKE.INSTANCE CREATE HERE SWAP 

12 DUP 9 DUP . ( Store key into Instc) 

13 SWAP SZ® ALLOTZ ( Allot Its storage) 

14 INITIALIZE IMMEDIATE 

15 DOES> DUP 9 DO.OR.COMP ; —> 

Screen # 9 

0 ( Type definitions 
1 

2 : INCLUDE> * >BODY 9 INHERIT l ; 

( Inherit ops from old type) 

3 

4 ( Juggle dictionary pointers to seal the type body) 

5 : LINKS HERE BODY> >LINK PUBLIC 9 SWAP I ( - ) 

6 LASTLOCAL 9 BODY> >NAME OPS 9 l 

7 INHERIT 9 LASTLOCAL 9 BODY> >LINK l ; 

8 

9 ( Close type declaration) 

10 : ENDTYPE> LATEST CREATE LINKS 

( Close the body) 

11 , SIZE 9 , ( Store key and size) 

12 FALSE IN.TYPE.DEF? I 

13 DOES> IN.TYPE.DEF? 9 IF MAKE.STRUCTVAR 

14 ELSE MAKE.INSTANCE 

15 ENDIF ; —> 


Screen # 10 

0 ( Array definitions 
1 

2 ( Calculate address of array element) 

3 : INDEX+ ROT * + ; ( Index PFA width addr) 

4 

5 ( Interpret an array operation) 

( index PFA key - ) 

6 : ARRAY.DO.OP FINDOP 
( Get operation CFA) 

7 ROT ROT 4 + DUP 9 

( Get width of element) 

8 INDEX+ 

( Calculate element address) 

9 OPUSH EXECUTE OPOP ; ( Do it!) 

10 

11 ( Place index on stack at compile time) 

12 : VAL[ TRUE VAL ! [COMPILE] [ ; IMMEDIATE 

13 

14 ( Reset the VAL flag) 

15 : -VAL FALSE VAL ! ; —> 


Screen # 11 

0 ( Array definitions 
1 

2 ( Compile an array operation) 

( {index} PFA key - ) 

3 : ARRAY.COMP.OP FINDOP >R 

( Get op CFA and stash it) 

4 4 + DUP 9 

( Get width of array) 

5 VAL 9 

( Index at compile time?) 

6 IF INDEX+ COMPLIT 
( CompiIe el. addr) 

7 ELSE SWAP COMPLIT COMPLIT 

( or code to calc ) 

8 COMPILE INDEX+ ( at runtime) 

9 ENDIF 
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10 

11 

12 

13 

14 

15 


R> COMPILE.CALL ~VAL ; 

( comp!Ie op call) 

Compile or interpret an array op) 
index PFA key - ) 

ARRAY.DO.OR.COMP STATE @ IF ARRAY.COMP.OP 

ELSE ARRAY.DO.OP 
END IF ; —> 


Screen # 
0 


12 


Array definitions 

Create a typed array as an instance variable) 
count PFA-) 

ARRAY.VAR CREATE DUP ® , OVER , 



( Store key and 

count) 



3 

SZ® DUP , 

( Store 

width of element) 

4 

* 


( Size - 

■ count * width) 

5 

OFFSET 


( Store 

offset etc.) 

6 

IMMEDIATE 



7 

DOES> DUP 

@ 


( Get key) 

8 

FINDOP >R 


( Get op CFA and stash it) 

9 

DUP 6 + @ 



( Get offset) 

10 

2 - SWAP 4 

+ @ 


( Get width) 

11 ( 

; Compile el addr) VAL 

® IF 

INDEX* COMPILE.ADDOFF 

12 | 

r or code to...) 


ELSE 

SWAP COMPLIT COMPLIT 

13 1 

{ calculate It.. 

.) 


COMPILE INDEX* 

14 1 

[ at runtime) 


COMPILE OCOP+ 


15 ENDIF R> COMPILE.CALL ~VAL 


—> 


( count PFA - ) 


Screen § 13 

0 ( Array definitions 
1 

2 ( Make a new array instance) 

3 : MAKE.ARRAY CREATE 2DUP • 

( Store key and count) 

4 SZ® DUP , SWAP 

( Store width) 

5 * ALLOTZ 

( AI lot the space) 
IMMEDIATE 

DOES> DUP ® ARRAY.DO.OR.COMP 


6 

7 

8 
9 


Create an array object or variable) 


10 

11 

12 

13 

14 

15 


count +++ 
: ARRAY-OF 


) 


>B0DY 
IN.TYPE.DEF? ® 
IF ARRAY.VAR 
ELSE MAKE.ARRAY 
ENDIF ; 


Screen # 14 


DATA STRUCTURES EMPLOYED INTERNALLY 


0 ( 

1 

2 OBJECT 

3 

4 

5 

6 

7 

8 
9 

10 
11 

12 TYPE DEFINING WORD 

13 


width 


+-+- 

| header | key 

-+- 

i 

storage 

fields 

—+ 
i 






ARRAY-OF OBJECTS 





| header | key 

| count 

| width 

| elements 

i 

—+ 


14 | header | key | size | 

15 +-+-+-+ 

Screen # 15 

0 ( 

1 VAR NAME 

2 +-+-+ 

3 | header | offset | 

4 + -+-+ 

5 


[continued) 
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6 STRUCTVAR NAME 

8 | header | key | offset | 

9 +-+-+-+ 

10 

11 ARRAY.VAR NAME 

12 +-+-+-+-+-+ 

13 | header | key | count | width | offset j 

14 +-+-+-+-+-+ 

15 
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breakpt.asm 

Programming InsIght:"BrookIng Out," by Edward 
Batutis. September, page 127. Also see brkptcom.bas. 


; BREAKPT 

; Copyright 1985, Edward Batutis 

; Invokes the breakpoint Interrupt when Ctrl-Shift-Shift 
; combination Is pressed. 

; Assembled with the IBM Macro Assembler Version 1.00 


cseg segment 

para 

public 'code* 

assume 

csrcseg, 

dsrcseg 

org 

100h 


breakpt proc 

Jmp 

instal1 


copyright 

db 

•BREAKPT (c) Copyright 1985 

db 

* Edward J. Batutis•,01ah 

old_int9_vector 

label 

dword 

old_lnt9_offs 

dw 

? 

old_int9_seg 

new_J nt9: 

dw 

? 


; call old keyboard routine by simulating an Int 
pushf 


ca 1 1 

cs:o1d_lnt9_vector 


push 

es ; 

save registers 

push 

ax 


push 

bx 


mov 

ax,40h ; 

look at keyboard flagl in 

mov 

es.ax ; 

ROM BIOS data area 

mov 

bx,17h 


mov 

a 1,es:[bx] 


and 

a 1,07h ; 

mask off everything but lowest 


* 

three bits 

cmp 

a 1 ,7 ; 

are Ctrl-Shift-Shift depressed? 

jne 

quit ; 

no, quit 

; turn 

on the trap flag 


pop 

bx ; 

restore registers 

pop 

ax 


pop 

es 


push 

ax ; 

save register 

pushf 

* 

get flags into ax 

pop 

ax 


or 

ax,0100h ; 

set trap flag on 

push 

popf 

ax ; 

put new flags back 

pop 

ax ; 

restore ax 

nop 

! 

wait one Instruction 


Iret ; debug is invoked at this instruction 


[continued] 
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quit: 

P°P *> x ; restore registers when 

Pop ax • quitting 

pop es 

done: 

iret 

END_OF_RESIDENT_C0DE LABEL BYTE 


banner db 
InstalI: 


mov 

mov 

int 

cmp 

Jo 

mov 

mov 

mov 

mov 

Int 


mov 

mov 

mov 

Int 


mov 

Int 


*BREAKPT installed.’,10,13,'$' 


; get interrupt vector for 
; keyboard interrupt 


interrupt vector function 
interrupt 9 

; are we already installed? 

; yes, just exit 

; save old keyboard Interrupt 
; address 


ah,35h ; get 

al,9 ; get 

21 h 

bx,offset new_int9 
no_instalI 

oId_lnt9_of f8,bx 
oId_int9_seg,es 

dx,offset banner 
ah, 9 
21 h 


ah,25h 
al ,9 

dx,offset new_Int9 
21 h 


; print banner 
; print string function 


; set keyboard Interrupt 
; to point to new_int9 
; set Interrupt function 
; set Interrupt 9 
; point to new routine 


terminate, but stay 
partially resident 
point to last byte of resident 
routlnes+1 


dx.offset END_OF_RESIDENT CODE+1 
27h 


no_instalI: 

int 20h 

breakpt endp 

cseg ends 

end breakpt 


don't instalI, Just exit 


brkptcom.bas 

Programming Insight:"Breaking Out," by Edward 
Batutis. September, page 127. Also see breakpt.asm. 


100 

110 

120 

140 

150 

160 

170 

180 

190 

200 

210 

220 

230 

240 

250 

260 

270 

280 


'RUN THIS PROGRAM TO CREATE breakpt.com 
PRINT "Creating breakpt.com" 
OUTFILE$*"breakpt.com" 

DATA &hEB, &h74, &h90, &h42, &h52, 4h45, 
DATA &h20, &h28, &h63, &h29, &h20, &h43, 
DATA &h69, &h67, &h68, &h74, &h20, &h31, 
DATA &h20, &h45, &h64, &h77, &h61, &h72, 
DATA &h20, &h42, &h61, &h74, &h75, &h74, 
DATA &h00, &h00, &h00, &h9C, &h2E, &hFF, 
DATA &h50, &h53. &hB8, &h40, &h00, &h8E, 
DATA &h26, &h8A, &h07, &h24, &h07, &h3C, 
DATA &h58, &h07, &h50, &h9C, &h58, &h0D, 
DATA &h58, &h90, &hCF, &h5B, &h58, &h07, 
DATA &h41, &h4B, &h50, &h54, &h20, &h69, 
DATA &h6C, &h6C, &h65, &h64, &h2E, *h0A, 
DATA &hB0, &h09, &hCD, &h21, &h81, &hFB, 
DATA &h89, &h1E, &h31, &h01, &h8C, &h06, 
DATA &h01, &hB4, &h09, *hCD, &h21, &hB4, 


&h41, 

&h6F, 

&h39, 

&h64, 

&h69, 

&h1E, 

&hC0, 

&h07, 

&h00, 

&hCF, 

&h6E, 

&h0D, 

&h35. 

&h33, 

&h25, 


&h4B, 
&h70, 
&h38, 
&h20, 
&h73, 
&h31, 
&hBB, 
&h75, 
&h01, 
&h42, 
&h73, 
&h24, 
&h01, 
&h01, 
&hB0, 


&h50, 
&h79, 
&h35, 
&h4A, 
&h1A, 
&h01, 
&h17, 
&h0E. 
&h50, 
&h52, 
&h74, 
&hB4, 
&h74, 
&hBA, 
&h09. 


&h54 
&h72 
&h2C 
&h2E 
&h00 
&h06 
&h00 
&h5B 
&h9D 
&h45 
&h61 
&h35 
&h ID 
&h61 
&hBA 
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290 DATA 4h35. 4h01, 4hCD, 4h21. 4hBA, 4h62. 4h01. 4hCD, 4h27, 4hCD 
300 DATA 4h20 
310 TOTAL- 161 

320 OPEN OUTFILE$ AS #1 LEN-1 
330 FIELD #1.1 AS A$ 

340 FOR 1-1 TO TOTAL 

350 READ A 

360 LSET A$-CHR$(A) 

370 PUT 1 

380 NEXT 
390 CLOSE 
400 PRINT"Done." 

410 END 


ccitt.c 

Programming Project:"CaIcuI ating CRCs by Bits and Bytes," 
by Greg Morse. September, page 114. Also see xmodem.c, 
sdlc.asm, and xmodem.asm. 


/* Straightforward, non-optimlzed CRC-CCITT 
routine */ 

/* Assumes 16-bit integer variables */ 

/* MSB of integer is MSB of CRC result */ 

#define POLY 0x8408 

/* POLY - 1021 In bit rev order*/ 

BLKCRC(bufptr, crcres, count) 
unsigned char *bufptr; 
unsigned Int *crcres, count; 

^ Int i; 

♦crcres - 0; /* for SDLC use 0xFFFF */ 

for (1-1; !<-count; ++1, bufptr++) /* do for whole BLK*/ 
bytecrc(bufptr, crcres) /* do CRC for 1 char */ 
return (*crcres); 

} /* end BLKCRC */ 

bytecrc(bufptr, crcres) 
unsigned char *bufptr; 
unsigned Int *crcres; 

unsigned Int j,ch,Q; 

ch - (unsigned int) *bufptr; /* get char, to int fmt*/ 
for (J-1; j<«8; J++) | /* do each bit LSB 1st */ 

Q-(*crcres&0x0001)^(ch&0x0001)/* Q-R0 XOR D */ 

If ( Q — 0x0001) { /* Q is one */ 

♦crcres- *crcres»1; /* shift right one */ 
♦crcres- *crcres~POLY; /* XOR with number */ 

else /* Q is zero */ 

♦crcres- *crcres»1; /* just shift no XOR */ 
ch - ch »1; /* move next data bit*/ 

/* into position */ 

} /* end FOR - data bits all done */ 

return (*crcres); 
f /* end bytecrc */ 


exps.st1 

"Atari ST Software Development," by Michael Rothman. 
September, page 223. 


********** Example 1 ********** 

/* format.c */ 

/* Format a floppy disk on the ST. Return 0 If sucess,*/ 
else non-zero. 

Edit History: 

000 19-Sep-85 MR Creation 

001 07-Feb-86 MR Modified for BYTE article [continued) 
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/* #deflne DEBUG 1 */ 

#fnclude <osblnd. /* C bindings for OS routines */ 

#deflne HITRACK 79 /* Highest numbered track */ 

fdeflne SECTORS 9 /* Sectors per track */ 

#deflne MAGIC 0x87654321L/* Required by Flopfmt() */ 

#deflne VIRGIN 0xE5E5 /* Pattern to write to sectors */ 
#deflne ILEAVE 1 /* Interleave factor */ 

fdeflne DISKTYPE 2 /* Single side, 80 track */ 

fdeflne NOLOAD 0 /* No loader code In boot sector */ 

fdeflne RANDOM 0x1000000L/* make protobt make a random */ 

fdeflne BOOTSECT 1 /* Side 0, sect 1 gets boot sect */ 

fdefine TRACK0 0 /* Track for boot sector */ 

fdeflne SIDE0 0 /* Format side 0 */ 


extern void errprlnt(); 

/* error notification routine */ 


format(devno) 

Int devno; /* device holding media to format */ 

/* Automatic variables */ 

/* count tracks */ 
register Int I; 

/* buffer for track, protoboot */ 
register char *buf; 

/* success In format? */ 
register Int succ, totsucc » 0; 

/* doesn't do anything */ 
long fI I Ier; 

/* Code */ 

/* Allocate memory for track. The ST formate one 
track at a time, and requires sufficient RAM to 
verify that track in memory. Malloc Is a GEMOOS 
call. */ 

buf « MaIloc(8192L); 


#1fdef DEBUG 

errprlnt(0, "insuff memory for format"); 
#endif 

return(-l); 


/* Format each track. VIRGIN is the value to write 
to the newly formatted track. This particular value 
(0xE5E5) is suggested in the documentation, but many 
values are possible. Flopfmt is XBIOS. */ 
for (i-HITRACK; l>«0; i—) 

succ = Flopfmt(buf, filler, devno, SECTORS. 

i. SIDE0, ILEAVE, MAGIC. VIRGIN); 
totsucc +* succ; 


/* Release memory. GEMDOS */ 

Mf ree(buf); 

/* For the purposes of this routine, I won’t accept 
any bod sectors. But, if there were any, their numbers 
would have been left in the buffer, buf, after each 
track was formatted. I could alternatively retried, 
or recorded the bad sectors if I were developing my 
own file system. */ 


if (totsucc !» 0) 


#1fdef DEBUG 
#endIf 

I 


errpr!nt(totsucc, "format failed"); 
return(-1); 
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/* Now we need to put a boot sector on the disk. */ 

/* Allocate a 512 byte buffer */ 
buf - Mai Ioc(512L); 

/* Prototype a boot sector in that buffer. 

The second parameter is a serial number for the 
disk. The value I have chosen asks the XBIOS 
to generate a random number. XBIOS */ 

P r o t o b t(b u f,RANDOM,DISKTYPE,NO LOAD); 

/* Write out the boot buffer to track 0, side 0. 

Last parameter is how many sectors to write. */ 

succ - FIopwr(buf.filler,SIDENO,BOOTSECT,TRACK0,SIDE0,1); 

/* Throw away memory */ 

Mf ree(buf); 

/* Return success or failure */ 
return (succ); 

\ 


********* Example 2 ******** 

This is a trap handler of the sort you might use if you 
were programming the ST in 68000 assembler, or you were 
using a high level language and needed to write a binding 
for access to a BIOS, XBIOS or GEMDOS function. The 
functions assume the C calling conventions, that is, if 
there are any parameters, they are assumed to have been 
pushed onto the stack In reverse order, and to be no smaller 
than a word (16 bits). The number of the routine itself 
must be pushed last, Just before the trap call. Of course 
if you are developing using the C provided in Atari's kit 
for developers, this process will be transparent to you, 
since a set of bindings is available which makes TOS calls 
look Just like ordinary C function calls. 

; At entry, any arguments for the function have been 
pushed on the stack 

; In reverse order, C-style. Then the function number 
was pushed. 

; Finally this routine was called, so as we enter the 
return address of 

; the caller Is on top of the stack. 


retsv: ds.l ; some memory for a long variable 


traprtn: 

move.I (a7)+, retsv 
trap #13 

move.I retsv, -(a7) 
rts 


Save off the return address, 
because the OS functions don't 
expect it. 

Trap to the BIOS function. (BIOS 
is available through trap 13, 
XBIOS through 14, GEMDOS through 
trap 1). 

Put the return address back on 
stack. 

Return to caller. 


********** Example 3 ********** 

/* SAMPLE.C Original version provided by Atari as 
part of the developer's kit. Rearranged, cleaned up, 
defines added, many variable names changed,and all 
comments added by M.R. 

*/ 

/* This program is a simple example of use of some 


( continued ) 
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VDI primitives and certain parts of the AES, In particular 
the window library and the event handler. It opens a 
window on the desktop and draws a filled ellipse In It. 

It waits for the user to move the window or resize It 
and then redraws the ellipse. If the user selects the 
window close box, the program closes the window 
and then terminates. 

*/ 

/* Defines. These ore all Just for readtblllty. */ 

Idefine COLOR0 0 7 ' 

Idefine COLOR1 1 
#deflne SCREEN 1 
Idefine SOLID 1 
Idefine PATTERN 2 
#define USER 4 
#deflne DOT 1 
Idefine SYSTEM 1 
Idefine RC 2 
Idefine ARROW 0 
Idefine WORKAREA 4 
Idefine WNAME 2 
Idefine WINDAREA 1 
#deflne CLIPON 1 
#define WM.REDRAW 20 
idefine WM.CLOSED 22 
idefine WM.SIZED 27 
Idefine WM_MOVED 28 
idefine WF_CURRXYWH 5 

/* Window type bits */ 
idefine NAME 0x0001 
Idefine CLOSE 0x0002 
idefine MOVE 0x0008 
Idefine SIZE 0x0020 


/* These arrays are used by the VDI In Its own code. 
The developer Is expected to allocate room for them 
somewhere In the application. */ 

Int contrI[12], lntin[256], ptsin[256], lntout[256l. 
ptsout[256]; 

main() 

{ 

/* Local variables */ 

/* For the workstation */ 

Int workln[l0]; /* Input values for v_openvwk() */ 
Int workout[56]; /* Ouput values for v_openvwk() */ 
Int shandle; /* Workstation (screen) handle */ 


/* Variables for our appIIcatIon's window */ 


Int 

Int 

Int 


whandle; 
w!nd_type; 
xwork; 


Int ywork; 

Int wwork; 
Int hwork; 
int xbord; 

Int ybord; 


Int 

Int 

Int 


/* Window handle */ 

/* Holds window attribute bits */ 

/* X coordinate, upper left hand corner, 
work area of window */ 

/* Y coordinate, upper left hand corner, 
work area of window */ 

/* Width, work area of window */ 

/* Height, work area of window */ 

/* X coordinate, upper left hand corner, 
border of window */ 

/* Y coordinate, upper left hand corner, 
border of window */ 

Width, border area of window */ 
Height, border area of window */ 


/* 

/• 


wbord; 
hbord; 

xcen, ycen; /* Coordinates of central point i^window */ 


/* These four variables are returned by graf_handIe() 
(described later). They are not used further in 
this applIcation. */ 


Int gr_wchar, gr — hchar; /* Width and height of a character 
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cell for font used In menus and 
dialogs */ 

int gr wbox, grjibox; /* Width and height of box large 

enough to hold a system font 
character */ 


/* Mi see I Ianeous */ 

int ap_id; /* Application id */ 

int cl!p[4]; /* Holds coordinates defining clip region */ 

Int mgbuf[8]; /* Buffer for message events from AES */ 

int dummy; /* Word buffer for miscellaneous use */ 


/* Begin program */ 

/* AppI_Init Is the AES initialization routine. 

It makes the AES aware of the application, and 
Initializes certain AES data structures. The 
application id It returns can be used later by 
the application for other AES routines. */ 

ap_Id = appl_Inlt(); 

/* When the application starts, GEM has already opened 
the screen workstation for its own use. Therefore the 
screen has a workstation handle (identifier). We need 
this handle to open our own virtual workstation with the 
attributes we would like. The routine graf_handle 
(part of the AES graphics library) returns this handle. 

It also puts certain character size info Into the passed 
parameters (which we don't happen to need). */ 

shandle - graf.handIe(&gr_wchar,&gr_hchar,&gr_wbox,&gr_hbox); 

/* Now we can open a virtual workstation. If the 
attributes of the GEM opened physical workstation were 
to our liking, we could just use it. Or we could change 
the attributes with VDI attribute calls. As often Is 
the case, GEM provides redundancy - a decision as to 
elegance is up to you. 

The workin array will define the default attributes we 
want. Note these are all defaults. We will modify some 
during the main loop of the program. */ 

/* The device type - 1 is for screen */ 
work In[0] - SCREEN; 

/* Set the line type to a solid line */ 
work!n[1] * SOLID; 

/* Polyline color index to 1 (The background color 
defaults to whatever Is In color register 0. 

The foreground to whatever is In register 1. So by 
selecting 1, we are selecting the default foreground 
color. Incidentally, on a monochrome system. 0 
defaults to white, and 1 to black. Thus the screen 
has that black on white, Mac-1 Ike appearence). */ 
work!n[2] - C0L0R1; 

/* Marker type 1 - which happens to be a dot. 

This is set for completeness; there is no use of the 
polymarker routine In this application. */ 
workln[3] ■ DOT; 

/* Polymarker color set to 1. Ditto */ 
workln[4] - COLOR1; 

/* Text face to the system face */ 
work In[5] - SYSTEM; 

/* Text color */ 
workln[6] - C0L0R1; 

/* Fill interior style. The available styles for a 
fill are hollow, solid, pattern, hatch, and user-defined. 
Hollow fills with the background color (index 0). 


(continued) 
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Solid with the currently selected fill color. The other 
three choices are further modified by the fill style 
Index (see the next entry In array) to pick the fill 
pattern. 

*/ 

workin[7] - SOLID; 

/* Fill Index style. This modifies fill Interior style 
to seIect the actual fill style (unless the Interior 
style is solid or hollow). We’ll Just select the 
default 1. */ 
workln[8] - 1; 

/* Fill color. */ 
workfn[9] - C0L0R1; 

/* The last entry In the array selects either roster 
coordinates (machine specific) or normalized device 
coordinates (portable). */ 
workin[10] ■ RC; 

/* Open our virtual workstation, passing It the 
Input orray, the physical workstation handle, and 
the ouput array. Note, the virtual workstation’s 
handle Is returned In the same variable which held 
the physical handle. A VDI routine. */ 

v_opnvwk(workIn, ishondle, workout); 

/* Set the mouse cursor form to the arrow. Yes, 
this is the default anyway, but this is supposed 
to be an example program, you know? The second 
parameter In grof_mouse Is a dummy In this case. If 
the mouse form selected was not pre-deflned, the 
second parameter would have to be a pointer to 
a mouse form definition block - a data structure 
for defining a mouse-driven cursor. Graf_mouse Is 
an AES routine. */ 

g r a f_mou se(ARROW,idummy); 

* Time to get Into the meat of the problem. We want 
to create a window for our application. The first thing 
to do Is get the size of the desktop window. This Is 
a window GEM creates when the system boots. Since it 
occupies the entire screen. It Is a guide to the maximum 
area our application can use. The function wlnd_get can 
be used to get various values; here we are going to 
get the size of the work area (area not Including border) 
of the desktop window (the first parameter is 0, Indicating 
the desktop window). Since we Intend OUR window to use 
this entire area, we put the results Into the variables 
we will be using to define the border of our window. This 
and all the functions beginning wlnd_ are AES functions. */ 

wlnd_get(0.WORKAREA,&xbord,&ybord.&wbord,*hbord); 

/* Now we know the size for our window. To create It, 
we need to specify Its attributes, and Its border size. */ 

/* We wont a window with a name, a close box, a move 
bar and a size box... */ 

wlnd_type - NAME | CLOSE | MOVE | SIZE; 

/* O.K. Make me a window. This call sets up 
Internal data structures and establishes the maximum 
size for the window, but It does not actually draw 
the window on the screen. */ 

whondle ■ wlnd_create(wlnd_type,xbord,ybord,wbord.hbord); 

/* We specified we wanted a window with a name, 
but now we need to specify what that name Is. 

This function can also be used to set or change 
other window parameters. */ 


284 BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 




September 


w 1 n d_s e t(wh a n dI«, WNAME, "S AMPLE " . 0 . 0 ) ; 

/* At last, draw the window. We have decided to draw 
It initially in its full size, but we could vary the 
last four parameters of this function if we desired 
otherwise. */ 

wind_open(whandle.xbord,ybord,wbord,hbord); 

/* Incidentally, we have never found out the size of 
the work area of our window. We’ll need that later, 
so let’s do It with the wlnd_calc function. This 
function, given the window type can determine either 
the border or the work area dimensions. */ 


wind_calc(WINDAREA,wind_type,xbord,ybord,wbord.hbord, 
ftxwork,&ywork.fcwwork,&hwork); 


/* Now, draw the filled ellipse In our window and 
wait for messages from the AES. If it’s a window 
resize or move message, recalculate the window work 
area, clear it, and redraw the ellipse. */ 


do 

/* If the user expands the size of the window, not only will 
the AES send a resize message, it will also send a redraw 
message, on the assumption that more of the window is 
visible, and you might want to update It. We are redrawing 
the entire visible portion of the window work area on receipt 
of a resize message anyway, so we can ignore the redraw 
message. */ 

if (mgbuf[0] !- WM_REDRAW) 

/* Hide the cursor. Otherwise area under it will not 
be affected by VDI routines. AES. */ 
v_hlde_c(shandle); 

/* Set up the clipping rectangle to equal the work 
area of the window. Actually, we have no Intention 
of drawing outside these boundaries anyway, but as 
I said, this is a demo program, so here’s how you 
specify clip. All subsequent graphic primitives In 
the VDI will respect these boundaries, unless the 
routine Is called again with a different clip 
rectangle, or with the second parameter set to 0 
(which means turn clipping off altogether). VDI. */ 


clip 

clip 

clip 

clip 


■xwork; 

■ywork; 

■xwork+wwork-1; 
ywork+hwork-1; 


vs_cllp(shandle,CLIPON,clip); 


/* Let’s clear the window work area to background color. 
There are lots of ways to do this. Here we set the 
interior fill style to pattern, the interior style index 
to 8 (which selects a "solid" pattern), and the fill 
color to 0, the background color. Then we call a 
primitive - v_bar, which draws a filled bar of the 
size defined by Its second parameter (for which we 
used the already available clip rectangle). All these 
routines are VDI. */ 


vsf_lnter lor(shandIe,PATTERN); 
vsf_styIefshand I e , 8 ); 
vs f_co I or(shand I e,COLOR0); 
v_bar(shandle,clIp); 


/* Set the fill Interior and color 
to the desired style. Calculate the ellipse 
center point. And vollal - draw the ellipse. 
These are all VDI routines. */ 


[continued) 


BYTE LISTINGS SUPPLEMENT • IULY-SEPTEMBER. 1986 285 






September 


vs fainter lor(shandIe.USER); 
vsf_coI or(shandI e, 1); 
xcen«xwo r k+wwo r k/2; 
ycen*ywork+hwork/2; 

v_el 1 ipse(shandIe,xcen,ycen,wwork/ 2 ,hwork/ 2 ); 

/* Reshow the cursor, since we're done drawing. AES. */ 
v_show_c(shandle); 

/* End of the part we don't do on a redraw message. */ 

/* O.K. Go to sleep until we get a message that the user 
has done something Interesting. AES. */ 
evnt_mesag(&mgbuf;; 

/* user wanted to resize window or move It, the 
new border coordinates will have been left In the message 
buffer, positions 4 through 7. Use them to recalculate 
the work area size and reset the coordinates of the entire 
window. */ 

If (mgbuf[0] — WM_SIZED || mgbuf[0] — WMJ40VED) 

wind_calc(WINDAREA,wind_type,mgbuf[4],mgbuf[5], 

mgbuf[6],mgbuf[7],ixwork,&ywork, 

&wwork,&hwork); 

w!nd_set(whandle,WF_CURRXYWH,mgbuf[4],mgbuf[5], 
mgbuf[6],mgbuf[7]); 


/* Repeat until the message from the AES says 
the user clicked the window close box. */ 
while (mgbuf[0] !- WM_CLOSED); 


/* Close and delete the window. The data structure 
remains allocated until a window delete. */ 

wfnd_close(whandle); 
wlnd_deIete(whandIe); 

/* Close the virtual workstation. */ 
v_clsvwk(shandle); 

/* Tell the AES the application Is done, 
and terminate */ 
appl_exlt(); 


sdlc.asm 

Programming Project:"CalculatIng CRCs by Bits and Bytes," 
by Greg Morse. September, page 114. Also see xmodem.c, 
ccltt.c, and xmodem.asm. 


* part A: calling main pgm for SDLC subroutine 

* 

NAM SDLC 

Sttl Calculate SDLC FCS a byte at a time 
Ifpl use /d0/defs/os9def8 
use /d0/defs/os9defs 
endc 


mod CRCsIz.CRCnam,prgrm+objet,reent+1.CRCBeg.CRCMem 
CRCNam fes "SDLC” 



org 

0 

CRCReg 

equ 

. ; ;keep 

CRCHI 

rmb 

1 ;; these 

CRCLO 

rmb 

1 ;; statements 

Temp 

rmb 

1 ;; 

stakbot 

rmb 

200-. 

CRCMem 

equ 

• 

CRCBeg 

equ 

♦ 


together 
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do CRC on "T" 
show result * $1B26 


do CRC on "THE" 
show result ■ $44BE 


do CRC on fox text 

show result * $DF91 

"txmit" 1's complement of CRC 

"txmlt" LSB first 
then MSB 
do CRC on fox 
and FCS 


show result ■ $F0B8 always 


* . . 

•port B: Calculation subroutine "SDLC" 28 AUG 85 

* PUBLIC DOMAIN SOFTWARE DONATED BY: 

• GREG MORSE Richmond B.C. CANADA 
% 

CRCRtn equ * begin BYTE-wise FCS-SDLC 

♦ ; + 

* Calculate the FCS-SDLC value for a block of data 

* Polynomial used * X**16 + X**12 +X**5 +1 

* data is processed as If by SDLC chip that is 

* LSB of char first 

* on entry: 

* X points to data buffer 

* D contains number of chars In buffer <* 32767 

* mem locations CRCHi, CRCLo, Temp are don’t care 

* They must occupy adjacent locations with CRCHi 

* at the low address 

* On Exit 

* X point past last char in buffer 

* D new CRC value for block 

* CRCHI,CRCLO new CRC for block 

* Temp destroyed 

* 

♦ DOC NOTES: 

♦ T ■ Data eor CRCLo 

♦ U « (T7 T6 T5 T4 0 0 0 0) eor (T3 T2 T1 T0 0 0 0 0 

♦ V7» (U7 0 0 00000; eor (T1 0 0 00000 

* During calcs CrcLo not needed so is used as 

* scratch area. 

* The Inner loop from CRC.10 takes 86 cycles 

* The routine requires 1 byte of scratch 

* 2 bytes for the result, and 6 bytes of stack 

*5- 

pshs y 
leay d,x 
pshs y 
Idd #$FFFF 
std CRCReg 
DoByt equ 

♦ 

Idb crclo 
CRC.10 equ 
eorb ,x+ 
tfr b,a 
andb #$F0 
anda #$0F 
std CRCLo 
I s I a 
I s I a 

(continued) 


save users y 

start addr + byte count equals 
ending address plus 1 
init FCS to all 1’s 
initialize CRC area 
* alt entry point for 1 byte CRC calc 
needs modified return see CRC.99 

♦Begin Inner Loop one loop per byte CYCLES 
B-T7 T6 T5 T4 T3 T2 T1 T0 

A-T7 T6 T5 T4 T3 T2 T1 T0 

B*T7 T6 T5 T4 0 0 0 0 

A- 0 0 0 0 T3 T2 T1 T0 

A—>CRCLo; B—>Temp 
A- 0 00 T3 T2 T1 T0 0 

A- 0 0 T3 T2 T1 T0 0 0 


1 eax 

foxmsg,PCR 

Idd 

#i 

bsr 

crcrtn 

Idy 

#0 

Ibsr 

shoregs 

1 eax 

foxmsg,PCR 

Idd 

#3 

bsr 

crcrtn 

Idy 

#i 

Ibsr 

shoregs 

1 eax 

foxmsg,PCR 

Idd 

#foxsiz 

bsr 

crcrtn 

Idy 

#2 

Ibsr 

shoregs 

coma 

comb 

stb 

FoxCRC,PCR 

sta 

FoxCRC+1,PCR 

1 eax 

foxmsg,PCR 

Idd 

#foxsiz+2 

bsr 

crcrtn 

Idy 

#3 

Ibsr 

shoregs 

cl rb 
os9 

F$Ex1t 
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18 1 a 


A- 0 T3 T2 T1 T0 0 0 

0 

18 1 a 


A- T3 T2 T1 T0 0 0 0 

0 

eora 

Temp 

A- U7 U6 U5 U4 0 0 0 

0 

eora 

CRCLo 

A- U7 U6 U5 U4 T3 T2 T1 

T0 

sta 

Temp 

temp- U7 U6 U5 U4 T3 T2 

T1 T0 

c 1 rb 




1 sra 


A- 0 U7 U6 U5 U4 T3 T2 

T1 

rorb 


B-T000 0 0 0 0 0 

eorb 

Temp 

B- V7 U6 U5 U4 T3 T2 T1 

T0 

1 sra 


A- 0 0 U7 U6 U5 U4 T3 

T2 

rorb 


B- T1 V7 U6 U5 U4 T3 T2 

T1 

Isra 


A- 0 0 0 U7 U6 U5 U4 

T3 

rorb 


B- T2 T1 V7 U6 U5 U4 T3 

T2 

Isra 


A- 0 0 0 0 U7 U6 U5 

U4 

rorb 


B- T3 T2 T1 V7 U6 U5 U4 

T3 

Isra 


A- 0 0 0 0 0 U7 U6 

U5 

rorb 


B= U4 T3 T2 T1 V7 U6 U5 

U4 

eorb 

CRCHI 

B- new CRCLo 


eora 

Temp 

A- new CRCHI 


std 

CRCReg 

one data byte all done 


RC.99 

equ 

•make RTS If doing only 1 

byte 

cmpx 

*s 

x past end of buffer? 


bio 

CRC.10 

if not repeat inner loop 

Note: 



B still = CRCLo 


1 eas 

2,8 

pop topaddr 


pu 1 s 

y.pc 

restore y and return 


♦FoxMsg equ 

* 


fee 

/THE.QUICK,BROWN.FOX,0123456789/ 


foxsiz 

equ 

♦-foxmsg 


foxcrc 

fdb 

0 room for fox FCS bytes 


USE shoregs.src 

utility subrtn to print reas 

emod 


os9 directive 


CRCSIz 

equ 

* 



(28) 

(32) 

(36) 

(40) 

(42) 



(54) 


(58) 

(62) 

( 66 ) 

(70) 

(74) 

(79) 



skam.bas 

"Keyed File Accese In BASIC," by Stephen C. Perry. 
September, page 137. Also see skaml.bas. 


1 *- 

2 | SAMPLE PROGRAM USING KEYED ACCESS ROUTINES - 

5 UA$«"A" * .. DRIVE CONTAINING DATA 

16 OPEN “R",#2,UA$+":DATA.EMP",84 * .. OPEN DATA FILE 

AS A2$^VaS ZP$ S KY$ ’ 20 AS NM$ ’ 6 AS BD$ ’ 1 AS SX$ ' 3 AS JC $* 20 AS A1$, 20 
18 * 

19 * KY$ - ZIP CODE (KEY) JC$ - JOB CODE 

20 • NM$ - NAME A1$ - STREET ADDR. 

21 BD$ - BIRTH DATE A2$ - CITY-STATE 

22 ' SX$ - SEX ZP$ - ZIP CODE 

23 

25 MXX-150: F1$-"PTR.EMP" • ..INDEX FILE NAME 

30 IIX-1: GOSUB 2000 • ..INITIALIZE DATA STRUCTURE 

32 INPUT "OPERATION (D.A.L.S.LA,U.Q)";Q$ 

33 IF Q$«"D" THEN GOSUB 150: GOTO 32 ’ DELETE 

34 IF Q$-"L" THEN GOSUB 180: GOTO 32 * LIST INDIVIDUAL DATA 

35 IF Q$="A" THEN GOSUB 100: GOTO 32 > ADD 1V1UUAL UATA 

36 IF Q$-"S" THEN IIX-8: GOSUB 2000: GOTO 32 ’ DISPLAY STATISTICS 

37 IF Q$-"LA"THEN GOSUB 200: GOTO 32 • L ST ALL RECORDS 

38 IF Q$="U" THEN GOSUB 250: GOTO 32 • UPDATE RECORD 

40 IF Q$o"Q" THEN 32 UKU 

50 CLOSE: END 

97 * 

98 • ***** ADD RECORD 

99 • 

100 INPUT "SS#";A$ : IF A$«"END" THEN 120 ELSE IF LEN(A$1<>9 THEN ina 
ell II%-5:G0SUB 2000: IF RC%<>0 THEN LSET KY$=A$: GOTO 102 ELSE PRINT"** 
ERROR - KEY ALREADY EXISTS": GOTO 100 

102 INPUT "NAME“;F$: LSET NM$-F$ 

105 INPUT "BIRTH DATE";F$: LSET BD$«F$ 

107 INPUT "SEX";F$: LSET SX$-F$ 
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INPUT “JOB CODE";F$: LSET JC$-F$ 

INPUT "STREET";F$: LSET A1$=F$ 

INPUT "CITY-STATE";F$: LSET A2$«F$ 

INPUT "ZIP CODE";F$: LSET ZP$=F$ 

IIX-2: GOSUB 2000 ADD RECORD 

IF RCX-0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT BE STORED": GOTO 


II%-7: GOSUB 2000 
RETURN 

» 

• ***** DELETE RECORD 


STORE POINTERS 


IF A$«"END" THEN 156 


109 

110 
111 
112 

115 

116 
100 
120 
122 

147 

148 

149 * 

150 ST%-0 

151 INPUT "CODE TO DELETE";A$ 

152 II%*4: GOSUB 2000 

154 IF RC%«0 THEN ST%«1 ELSE 

155 GOTO 151 

156 IF ST%=1 THEN II%«7: GOSUB 2000 
158 RETURN 

177 * 

178 * ***** LIST INDIVIDUAL RECORD 

179 ' 

180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$*"END" THEN 190 rvTeTI( 

182 II%*5: GOSUB 2000: IF RC%<>0 THEN PRINT"**ERROR - KEY DOES NOT EXIST 

GOTO 180 

183 PRINT 

184 PRINT 

185 PRINT 


PRINT "** ERROR - KEY DOES NOT EXIST" 

RESTORE POINTERS IF RECORD DELETED 


"; NM$ 

•i . 

"1LEFT$(BD$,2);"/";MID$(BD$,3,2);"/":RIGHT$(BD$.2) 
";A1$ 


PAUSE 


NAME: 

JOB CODE: 

18$ PRINT "BIRTH DATE: 

187 PRINT " ADDRESS: - 

188 PRINT TAB(13);A2$:PRINT 

189 GOTO 180 

190 RETURN 

197 ' 

198 • ***** LIST RANGE OF RECORDS 

199 ’ 

200 NXX-0: IIX-6: KX-0 
202 NXX-NXX+1: GOSUB 2000 

204 IF RCXO0 THEN 210 

205 PRINT KY$,NM$ 

206 KX-KX+1: IF KX<10 THEN 202 ELSE INPUT ">";Q$ 

207 IF Q$<>"END" THEN KX-0: GOTO 202 
210 RETURN 

247 ' 

248 ’ ***** UPDATE RECORD 

249 * 

250 INPUT "SS#";A$: IF A$-"END" THEN 270 

252 IIX-5:G0SUB 2000 * .. FETCH RECORD TO BE UPDATED 

254 IF RCX-1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST":GOTO 250 

255 PRINT "NAME- /";NM$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET NM$«F$ 

Ilf Sint "BIRTH DATE: /" ;BD$INPUT F$: IF LEN(F$)<>0 THEN LSET BD$-F$ 
258 PRINT "SEX: /";SX$;"/";: INPUT F$: 

260 PRINT "JOB CODE: /";JC$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET JC$=F$ 

262 PRINT "STREET: /";A1$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET A1$=F$ 

263 PRINT "CITY-STATE- /";A2$INPUT F$: IF LEN(F$)<>0 THEN LSET A2$—F$ 

III PRIUJ "ZIP CODE:/";ZP$;"/";: INPUT F$: IF LEN(F$)<>0 THEN LSET ZP$=F$ 
266 IIX-3: GOSUB 2000 ’ .. RESTORE UPDATED RECORD 

268 PRINT “ ": GOTO 250 
270 RETURN 

1995 * _ 

1996 


1997 ' - FILE MANAGEMENT SUBROUTINES (IIX,MXX,F1$.A$,PTX.PT$, NXX.RCX) - 

1998 ’ - 

1999 * 

2000 RC%«0: IF II%<1 OR II%>8 THEN RCX-1: RETURN 

2001 IF II%*1 THEN 2006: ’ ELSE STORE VARIABLES USED BY SUBROUTINES 

2004 ZZ%(1)-J%: ZZ%(2)-JJ%: ZZ%(3)«K%:ZZ%(4)«L0%: ZZ%(5)»HI%: ZZ%(6)=Z% 

2005 * 

2006 ON 11% GOSUB 2035,2080,2090,2100,2150,2200,2250,2280 

2007 1 

2008 IF IIX-1 THEN 2010: * ELSE RESTORE VARIABLES USED BY SUBROUTINES 

2009 JX-ZZX(1): JJX-ZZX(2): KX-ZZX(3): L0X-ZZX(4): HIX-ZZX(5): ZX-ZZX(6) 

2010 RETURN 

2034 REM - (1) SUBROUTINE (MXX.F1$) - INPUT POINTERS AND KEYS 

2035 IF MXX<1 THEN RCX-1: RETURN 
2037 MRX-(INT((MXX+2)/64)+1)*64 


[continued ) 
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2038 DIM PT$(64),PTX(MRX),KE$(MX%),ZZX(8) 

2040 OPEN "R",#1,UA$+":"+F1$,128 ' INDEX FILE 

ns ^oMSe/MS* -1 ’* 2 As “*■ 2 as pt,(j,): next j * 

2051 FOR JX-1 TO INT(MRX/64) 

2052 GET 1,JX • .. INPUT RECORD CONTAINING 64 POINTERS 

to 64: KX “ KX+1: PT*(KX)-CVI(PT$(JJX)): NEXT JJX 

2055 NEXT JX 

2056 ’ 

2057 IF PTX(MRX)-0 THEN 2062 

2058 FOR JX-1 TO PTX(MRX)+PTX(MRX-1) 

2059 GET 2. JX: KE$(JX)-KY$ 

2060 NEXT JX 
2062 RETURN 

2079 REM - (2) SUBROUTINE (MRX.A$. RCX) — ADD RECORD TO FILE 

2080 GOSUB 2500 : IF KX>0 THEN RCX-1: GOTO 2088 
2083 GOSUB 2520 : IF ZX>MRX-1 THEN RCX-2: GOTO 2088 

2086 ISgjSg* " INSERT P ° INTER • PTX ( KX )- ZX 

2087 PUT 2.ZX • 

2088 RETURN 

2089 REM — (3) SUBROUTINE - REWRITE RECORD 

ip KXC0 THEN RCX-1: GOTO 2098 

.. STORE RECORD 


STORE NEW RECORD 


2090 GOSUB 2500: .. 

2092 PUT 2,PTX(KX) 

2098 RETURN 

2099 REM - (4) SUBROUTINE (MRX,A$,RCX) - DELETE A RECORD 

2100 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2110 
2102 ZX-PTX(KX): IF KX-PTX(MRX) THEN 2107 

ne * t « 

2110 RETURN* MR *^ =0: PTX ( MRX )“ PTX ( MRX ) -1: PTX(MRX-1)-JJX+1:PTX(MRX-2-JJX)-ZX 

2149 REM - (5) SUBROUTINE (MRX,A$,NXX,RCX) - READ RECORD BY KEY 

2150 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2155 

2152 GET 2,PTX(KX) INPUT RECORD 

2153 NXX-KX 
2155 RETURN 

2!!! REM - (6) SUBROUTINE (MRX.NXX.RCX) - READ RECORD BY SEQUENCE 

2200 IF NXX<0 OR NXX>PTX(MRX) THEN RCX-1: GOTO 2205 
2203 GET 2. PTX(NXX) 

2205 RETURN 

2249 REM - (7) SUBROUTINE (MRX) - RESTORE POINTERS 

2250 KX-0: ZX-INT((PTX(MRX)-1)/64)+1 
2252 FOR JX-1 TO ZX 

oof? T0 64: K%-KX+1:LSET PT$(JJX)«MKI$(PTX(KX)): NEXT JJX: PUT 1,JX 

2254 NEXT J% 

2255 KX-INT(MRX/64): IF ZX-KX THEN 2259 

22 INT(MRX/64) F ° R J%=1 T ° 641 LSET PT$ ( JX )“ MKI ^( PTX ( JX+K *)):NEXT JX:PUT 
2259 RETURN 

(8) SUBROUTINE — DISPLAY FILE STATISTICS 

" : IF PTX(MRX)-0 THEN PRINT “*« NO RECORDS IN FILE": GOTO 2290 
** FILE STATISTICS **": PRINT " " 

1. RECORDS IN FILE: ";PTX(MRX) 

2. DELETED RECORDS: ";PTX(MRX-1) 

3. LOWEST KEY: ";KE$(PTX(1)) 

4. HIGHEST KEY: ";KE$(PTX(PTX(MRX))) 


BINARY SEARCH 


2279 REM 

2280 PRINT 

2282 PRINT 

2283 PRINT 

2284 PRINT 

2285 PRINT 

2286 PRINT 

2287 PRINT 
2290 RETURN 

2498 * 

2499 REM - SUBROUTINE (MRX,A$, KX) — 

2500 IF PTX(MRX)«0 THEN KX—1: RETURN 
2502 LOX-0: HIX«PTX(MRX)+1 

2504 MX-INT((LOX+HIX)/2) 

2505 IF A$-KE$fPTX(MX)) THEN KX-MX: GOTO 2510 

2506 IF A$>KE$(PTX(MX)) THEN LOX-MX: ELSE HIX-MX 
2508 IF LOX+1 <> HIX THEN 2504 ELSE KX—HIX 
2510 RETURN 

2518 * 

ofo« R | M ~,^® R ^ TINE (MRS.PTX.ZX) - LOCATE FREE RECORD IN DATA FILE 
2520 IF PTX(MRX-1)-0 THEN ZX-PTX(MRX)+1: GOTO 2530 
2522 JX-PTX(MRX):JJX=PTX(MRX-1) 

o?i« ptx ( mpx -1)*PTX(MRX-1)-1: PTX(MRX-1-JJX)=0 

2550 RETURN 

2538 * 

” ,NSERT P0INTER INT0 P0,N,ER VECI0R 
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2542 FOR JX«PTX(MRX)+1 TO KX+1 STEP -1 

2544 PTX(JX)«PTX(JX-1) 

2545 NEXT JX 

2548 PTX(KX)«ZX: PTX(MRX)-PTX(MRX)+1 
2550 RETURN 

2997 ’ - 

2998 • - PROGRAM TO INITIALIZE INDEX FILE 

0999 *--------—-—-— 

3000 PRINT " “-.PRINT TAB(5); "** INITIALIZE INDEX FILE **"-.PRINT " " 

3001 INPUT "> DRIVE TO CONTAIN DATA";UA$ 

3002 INPUT "> FILE NAME";F$ 

3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MXX 
3006 MRX=(INT((MXX+2)/64)+1)*64 

300 I -OPEN FILE AND SET POINTERS TO 0 

111 ! *-.)* AS DUS,2 AS PTS(«) ; «XT 0* 

H\t P*** 1 *^ ™ JX " T0 - 8 *- sf^fffi'w’zETOjoWTERS 

3016 FOR JX-1 TO MRX/64 
3018 PUT 1,JX 

3022 PRINT" ": PRINT " INITIALIZATION COMPLETE ON DRIVE";UA$ 
3025 END 


skomi.bas 

"Keyed File Access In BASIC," by Stephen C. Perry. 
September, page 137. Also see skam.bos. 


SAMPLE PROGRAM USING KEYED ACCESS ROUTINES 


1 1 - 

2 ’ 

3 -- 

5 UA$-"A" * .. DRIVE CONTAINING DATA 

16 OPEN "R“,#2.UA$+":DATA.EMP",84 *.. OPEN DATA FILE 

17 FIELD #2, 9 AS KY$, 20 AS NM$, 6 AS BD$, 1 AS SX$, 3 AS JC$, 
20 AS A1$, 20 AS A2$, 5 AS ZP$ 


18 

19 

20 
21 
22 
23 


KY$ - ZIP CODE (KEY) JC$ - JOB CODE 

NM$ - NAME A1$ - STREET ADDR. 

BD$ - BIRTH DATE A2$ - CITY-STATE 

SX$ - SEX ZP$ - ZIP CODE 


25 MXX-150: F1$-"PTR.EMP" 

30 IIX-1: GOSUB 2000 

31 ’ 

32 INPUT "OPERATION (D,A,L,S,LA.U.Q)";Q$ 

33 IF Q$-"D" THEN GOSUB 150: GOTO 32 

34 IF Q$-"L" THEN GOSUB 180: 

GOTO 32 * LIST INDIVIDUAL DATA 

35 IF Q$«"A" THEN GOSUB 100: GOTO 32 

36 IF Q$«*"S“ THEN IIX-8: GOSUB 2000: 

GOTO 32 * DISPLAY STATISTICS 


.INDEX FILE NAME 
.INITIALIZE DATA STRUCTURE 


DELETE 


ADD 


37 IF Q$«"LA"THEN GOSUB 200: 

GOTO 32 * LIST ALL RECORDS 

38 IF Q$-"U" THEN GOSUB 250: GOTO 32 ' UPDATE RECORD 

40 IF Q$o"Q" THEN 32 

50 CLOSE: END 

97 ’ 

98 ' ***** ADD RECORD 

99 * 

100 INPUT "SS#";A$ : IF A$»"END" THEN 120 ELSE IF 

LEN(A$)<>9 THEN 100 _ „ 

101 IIX«5:G0SUB 2000: IF RCX<>0 THEN LSET KY$«A$: GOTO 102 ELSE 
PRINT"** ERROR - KEY ALREADY EXISTS": GOTO 100 

102 INPUT "NAME";F$: LSET NM$-F$ 

105 INPUT "BIRTH DATE";F$: LSET BD$-F$ 

107 INPUT "SEX";F$: LSET SX$-F$ 

109 INPUT "JOB CODE";F$: LSET JC$-F$ 

110 INPUT "STREET";F$: LSET A1$-F$ 

111 INPUT “CITY-STATE":F$: LSET A2$-F$ 

112 INPUT "ZIP CODE";F$: LSET ZP$-F$ 

115 IIX-2: GOSUB 2000 ADD RECORD 


[continued) 
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116 IF RCX-0 THEN 100 ELSE PRINT"** ERROR - RECORD CANNOT 
BE STORED": GOTO 100 

120 IIX-7: GOSUB 2000 STORE POINTERS 

122 RETURN 

147 * 

148 * ***** DELETE RECORD 

149 ’ 

150 STX-0 

151 INPUT "CODE TO DELETE";A$: IF A$-"END" THEN 156 

152 IIX-4: GOSUB 2000 

154 IF RCX-0 THEN STX-1 ELSE PRINT "** ERROR - KEY DOES NOT 

155 G0T0 T 151 

156 IF STX-1 THEN IIX-7: GOSUB 2000 * RESTORE POINTERS 

IF RECORD DELETED 

158 RETURN 

177 * 

178 * ***** LIST INDIVIDUAL RECORD 

179 * 

180 INPUT "SOCIAL SECURITY NUMBER";A$: IF A$«"END" THEN 190 

182 IIX-5: GOSUB 2000: IF RCX<>0 THEN PRINT"**ERROR - KEY 
DOES NOT EXIST": GOTO 180 

183 PRINT " " 

184 PRINT " NAME: ";NM$ 

185 PRINT " JOB CODE: “;JC$ 

186 PRINT "BIRTH DATE: ":LEFT$(BD$ > 2) : "/" : MID$(BD$.3.2); 

"/";RIGHT$(BD$,2) 

187 PRINT " ADDRESS: ";A1$ 

188 PRINT TAB(13);A2$:PRINT "" 

189 GOTO 180 

190 RETURN 

197 * 

198 * ***** LIST RANGE OF RECORDS 

199 ’ 

200 NXX-0: IIX-6: KX-0 
202 NXX-NXX+1: GOSUB 2000 

204 IF RCXO0 THEN 210 

205 PRINT KY$,NM$ 

206 KX-KX+1: IF KX<10 THEN 202 ELSE INPUT ">";Q$ * .. PAUSE 

207 IF Q$o"END" THEN KX-0: GOTO 202 
210 RETURN 

247 ' 

248 • ***** UPDATE RECORD 

249 ' 

250 INPUT "SS#";A$: IF A$-"END" THEN 270 

252 IIX-5:GOSUB 2000 * .. FETCH RECORD TO BE UPDATED 

254 IF RCX-1 THEN PRINT "** ERROR - RECORD DOES NOT EXIST"- 

GOTO 250 * 

255 PRINT "NAME: /":NM$:"/" : : INPUT F$: IF LEN(F$)<>0 

THEN LSET NM$-F$ J 

257 PRINT "BIRTH DATE: /";BD$;"/";: INPUT F$: IF LEN(F$)<>0 

THEN LSET BD$«F$ V ' 

258 PRINT "SEX: /";SX$;"/";: INPUT F$: IF LEN(F$)<>0 

THEN LSET SX$-F$ ' 

260 PRINT "JOB CODE: /";JC$INPUT F$: IF LEN(F$)<>0 
THEN LSET JC$-F$ ' 

262 PRINT "STREET: /";A1$ : "/";: INPUT F$: IF LEN(F$)<>0 

THEN LSET A1$-F$ V ' 

263 PRINT "CITY-STATE: /“:A2$:"/" : : INPUT F$: IF LEN(F$)<>0 

THEN LSET A2$-F$ ^ ' 

265 PRINT "ZIP CODE: /“;ZP$;"/";: INPUT F$: IF LEN(F$)<>0 

THEN LSET ZP$-F$ V ' 

266 IIX-3: GOSUB 2000 * .. RESTORE UPDATED RECORD 

268 PRINT " ": GOTO 250 

270 RETURN 

1995 ’ 

1996 ’ - 


1997 ' - 


FILE MANAGEMENT SUBROUTINES 
(IIX,MXX,F1$,A$,PTX.PT$, NXX.RCX) - 


1998 ’ - 

1999 * 

2000 RCX-0: IF IIX<1 OR IIX>8 THEN RCX-1: RETURN 

2001 IF IIX—1 THEN 2006: * ELSE STORE VARIABLES 

USED BY SUBROUTINES 

2004 ZZXm-JX: ZZX(2)-JJX: ZZX(3)-KX:ZZX(4)-L0X: 
ZZX(5)-HIX: ZZX(6)-ZX 

2005 * 
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2006 ON IIX GOSUB 2035,2080.2090.2100,2150.2200.2250,2280 


2007 * 

2008 IF IIX—1 THEN 2010: ’ ELSE RESTORE VARIABLES 

USED BY SUBROUTINES 

2009 JX-ZZX(I): JJX-ZZX(2): KX«ZZX(3): L0X-ZZX(4): HIX-ZZX(5): 
ZX-ZZX(6) 

2010 RETURN 

2034 REM - (1) SUBROUTINE (MXX,F1$) - INPUT POINTERS 

AND KEYS 

2035 IF MXX<1 THEN RCX-1: RETURN 

2037 MRX-(INT((MXX+2)/64)+1)*64 

2038 DIM PT$(64).PTX(MRX),KE$(MXX),ZZX(8) 

2040 OPEN "R",#1,UA$+":"+F1$,128 * INDEX FILE 

2042 FOR JX-1 TO 64: FIELD #1,(J%-1)*2 AS DU$, 

2 AS PT$(JX): NEXT JX 

2050 KX-0: IF LOF(1)-0 THEN 2062 

2051 FOR JX-1 TO INT(MRX/64) 

2052 GET 1,JX * INPUT RECORD CONTAINING 64 POINTERS 
2054 FOR JJX-1 TO 64: KX-KX+1: PTX(KX)-CVI(PT$(JJX)): 


NEXT JJX 

2055 NEXT JX 

2056 * 

2057 IF PTX(MRX)-0 THEN 2062 

2058 FOR JX-1 TO PTX(MRX)+PTX(MRX-1) 

2059 GET 2, JX: KE$(JX)-KY$ 

2060 NEXT JX 
2062 RETURN 

2079 REM - (2) SUBROUTINE (MRX,A$, RCX) — ADO 

RECORD TO FILE 

2080 GOSUB 2500 : IF KX>0 THEN RCX-1: GOTO 2088 


2083 GOSUB 2520 : IF ZX>MRX-1 THEN RCX-2: GOTO 20:5 

2085 KX—KX:GOSUB 2540 ' .. INSERT POINTER . ?~X<X)-ZX 

2086 KE$(ZX)-A$ 

2087 PUT 2.ZX ' STORE NEW RECORO 

2088 RETURN 

2089 REM — (3) SUBROUTINE - REWRITE RECORO 

2090 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2098 
2092 PUT 2,PTX(KX) * .. STORE RECORD 

2098 RETURN 

2099 REM - (4) SUBROUTINE (MRX,A$.RCX) - DELETE 

A RECORD 

2100 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2110 
2102 ZX-PTX(KX): IF KX-PTX(MRX) THEN 2107 

2104 FOR JX-KX TO PTX(MRX)-1: PTX(JX)-PTX(JX+1): NEXT JX 

2107 JJX-PTX(MRX-I) 

2108 PTX(PTX(MRX))-0: PTX(MRX)-PTX(MRX)-1: 

PTX(MRX-1)-JJX+1:PTX(MRX-2-JJX)*ZX 

2110 RETURN 

2149 REM - (5) SUBROUTINE (MRX.AS.NXX.RCX) - READ 

RECORD BY KEY 

2150 GOSUB 2500: IF KX<0 THEN RCX-1: GOTO 2155 

2152 GET 2,PTX(KX) INPUT RECORO 

2153 NXX-KX 
2155 RETURN 

2199 REM - (6) SUBROUTINE (MRX.NXX.RCX) - READ 

RECORD BY SEQUENCE 

2200 IF NXX<0 OR NXX>PTX(MRX) THEN RCX-1: GOTO 2205 
2203 GET 2, PTX(NXX) 

2205 RETURN 

2249 REM - (7) SUBROUTINE (MRX) - RESTORE POINTERS 

2250 KX-0: ZX-INT((PTX(MRX)-1)/64)+1 

2252 FOR JX-1 TO ZX 

2253 FOR JJX-1 TO 64: KX-KX+1:LSET PT$(JJX)-MKI$(PTX(KX)): 
NEXT JJX: PUT 1.JX 


2254 NEXT JX 

2255 KX-INT(MRX/64): IF ZX-KX THEN 2259 
2257 KX-(KX-1)*64: FOR JX-1 TO 64: 

LSET PT$(JX)-MKI$(PTX(JX+KX)): 

NEXT JX:PUT 1.INT(MRX/64) 

2259 RETURN 

2279 REM - (8) SUBROUTINE -- DISPLAY FILE STATISTICS 

2280 PRINT " “:IF PTX(MRX)-0 THEN PRINT "** NO RECORDS 
IN FILE": GOTO 2290 

2282 PRINT " ** FILE STATISTICS **": PRINT " " 

2283 PRINT " 1. RECORDS IN FILE: ";PTX(MRX) 

2284 PRINT " 2. DELETED RECORDS: ";PTX(MRX-1) 


(< continued I 
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2285 PRINT “ 3. LOWEST KEY: ";KE$(PTX(1)) 

2286 PRINT « 4. HIGHEST KEY: ";KE$(PTX(PTX(MRX))) 

2287 PRINT - - 
2290 RETURN 

2498 ' 

2499 REM - SUBROUTINE (MRX,A$, KX) — BINARY SEAI 

2500 IF PTX(MRX)-0 THEN KX—1: RETURN 
2502 LOX-0: HIX-PTX(MRX)+1 

2504 MX-INT((LOX+HIX)/2) 

2505 IF A$-KE$(PTX(MX)) THEN KX-MX: GOTO 2510 

2506 IF A$>KE$(PTX(MX)) THEN LOX-MX: ELSE HIX-MX 
2508 IF LOX+1 <> HIX THEN 2504 ELSE KX—HIX 
2510 RETURN 

2518 * 

2519 REM — SUBROUTINE (MRX.PTX.ZX) — LOCATE FREE 
RECORO IN DATA FILE 



PTX(MRX-1-JJX)-0 
2530 RETURN 

2538 * 

2539 REM — SUBROUTINE (MRX.KX.ZX) — INSERT POINTER 
INTO POINTER VECTOR 

2540 IF KX-PTX(MRX)+1 THEN 2548 

2542 FOR JX-PTX(MRX)+1 TO KX+1 STEP -1 

2544 PTX(JX)-PTX(JX-1) 

2545 NEXT JX 

2548 PTX(KX)-ZX: PTX(MRX)-PTX(MRX)+1 
2550 RETURN 

2997 ’- 


2998 * 

2999 ’ 


PROGRAM TO INITIALIZE INDEX FILE 


3000 PRINT * ":PRINT TAB(5);"** INITIALIZE INDEX 
FILE **":PRINT " " 

3001 INPUT "> DRIVE TO CONTAIN DATA";UA$ 

3002 INPUT "> FILE NAME";F$ 

3004 INPUT "> MAXIMUM NUMBER OF RECORDS FILE WILL HOLD";MXX 
3006 MRX-(INT((MXX+2)/64)+1)* 64 

3008 DIM PT$(64) 

3009 *-OPEN FILE AND SET 

POINTERS TO 0 

3010 OPEN "R",#1,UA$+":"+F$,128 

3012 FOR JX-1 TO 64: FIELD #1,(JX-1)*2 AS DU$,2 
AS PT$(JX):NEXT JX 

3014 ZR$-MKI$(0): FOR JX-1 TO 64: LSET PT$(JX)-ZR$: NEXT JX 

3015 *-STORE BLOCKS OF 

ZERO POINTERS 

3016 FOR JX-1 TO MRX/64 
3018 PUT 1.JX 

3020 NEXT JX 

3022 PRINT " “: PRINT " INITIALIZATION COMPLETE 
ON DRIVE";UA$ 

3025 END 


tbprolog.tst 

"Turbo Prolog," by Namfr Clement Shammas. September, 
page 293. 


Listing 1. Turbo Prolog List Reversal Test Program 
/* Turbo Prolog List Reversal Test Program */ 
domains 

list * integer* 
predicates 

append(11st,11st,I 1st) 
wrltestrlng(l 1st) 

IIps(11st) 

IIpshort(I 1st) 
rev(l1st,I? s t S 
cycle(lnteger) 
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goal 


time(0,0,0,0), 

write("Enter cycle length "), 
readlnt(N), 
eye Ie(N), 
time(H,M,S,F), 

write("Tlme - ",H,":",M,":",S,".",F),nI. 
cIauses 

append( [], L, L ). 

append( [ZjLI], L2, [Z|L3] ) append( LI, L2, L3 ). 
writestr!ng( N ). 

wr I testring( [H|T] ) wrlte( H ), writestrlng( T ). 


I Ips(L) rev( [1,2,3,4,5,6.7,8,9,10,11.12,13,14,15.16,17,18,19,20, 

21,22,23,24,25,26,27,28,29,30.31,32.33,34,35,36,37,38,39,40,41,42,43,44,45.46, 
47,48,49,50], L ). 

lipshort(L) rev( [1,2,3,4,5,6,7,8,9,10], L ). 



append( Z, [H], L ). 



N1 ■ N - 1, Iips(_), cycle(NI). 


Listing 2. Turbo Prolog Floating Point Test Program 


/* Turbo Prolog Floating Point Test Program */ 


predicates 

caIc(reaI,reaI) 

cycle(Integer, real,real) 

goal 

tlme(0,0,0,0), 

A - 2.71828, 

B « 3.14159, 

cycle(5000,A,B), 

tIme(H.M,S,F), 

wrIte("Time - -,H,-:-,M,-:-,$.".■,F),nI. 

cIauses 

calc(A,B) 

C « 1.0, 

Cl » C * A, 

C2 * Cl * B. 

C3 - C2 / A, 

C « C3 / B, 

BOUND(C). 

cycle(0,A,B) 

C = 1.0, 

Cl ■ C * A, 

C2 - Cl * B, 

C3 - C2 / A, 

C - C3 / B, 

wrIte("C - ”,C),nI. 

cycle(N.A.B) 


Ie(N,A,B) 
caIc(A,B), 

N1 - N - 1 , 
eye I e (N 1 ,A,B). 


{continued) 
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Listing 3. Turbo Prolog Sieve Test Program. 
/* Turbo Prolog Sieve test program */ 
domains 

11st - Integer* 
predicates 

IntegersCInteger,integer,I 1st) 
prImes(Integer,11st) 

8 I ft(I 1st, I 1st) 

remove(integer,I 1st,I 1st) 

cycle(Integer) 

goal 

tlme(0,0,0,0), 
cycle(10), 
t Ime(H,M,S,F), 

wrIte( M TIme - ",H,-:-,M,«:-,S.«.-,F),nI. 
clauses 

prlmes( Limit, Ps ) 

Integers^ 2, Limit, Is ), 
slft( Is, Ps ). 

Integers( Low, High, [Low|Rest] ) 

Low <- High, I, M ■ Low + 1, 
lntegers(M, High, Rest ). 

Integers( ). 



slft( New, Ps ). 


removed,[]»[]). 
remove(P,[IjIs],[I|NIsl) 
not( 0-1 mod P ),!, 
remove(P, Is, NIs). 
remove(P,[I|Is],NIs) 

0-1 mod P, 
remove(P, Is, Nit). 

cycle(0}. 

cycle(N) 

N1 - N - 1, 
primes(100,_), 
cycle(NI). 


Listing 4. Turbo Prolog Math Functions Test Program. 


/* Turbo Prolog Math Functions Test Program */ 
predicates 

eye Iesqrt(Integer, real) 
eyeleln(Integer,real) 
eye Ieexp(Integer.real) 
eye Ieatan(Integer.real) 
eye Iesln(Integer,real) 

goal 

time(0,0,0,0), 
cyclesqrt(1000,_), 
time(0,0,0,0), 
eye IeIn(1000,_), 
time(0,0,0,0), 
eye Ieexp(1000,_), 
tlme(0,0,0,0), 
cycleatan(l000,_), 
tlme(0,0,0,0), 
eyclesln(l000,_). 
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cIauses 

eye Iesqrt(0,R) R - sqrt(100.0), 
time(H,M,S,F), 

write("SQRT : ",H,":",M,": M ,S, M .",F),nI,!. 
cyclesqrt(N, R) s- 

N > 0, N1 - N - 1, R - sqrt(100.0), eye Iesqrt(N1,R). 

cycleln(0,R) R * ln(100.0), 
time(H,M,S,F), 

wrIte("LN : M ,H,":-,M, H :",S, M . M ,F),nI. 

cycleln(N, R) 

N > 0, N1 - N - 1, R - ln(100.0), eye IeIn(N1,R). 

cycleexp(0,R) R » exp(10.0), 
time(H,M,S,F), 

wrlte("EXP : ",H, M : M ,M, M :",S,".",F),nI. 

cycleexp(N, R) 

N > 0, N1 - N - 1. R - exp(10.0), eye Ieexp(N1,R). 

cycleatan(0,R) R * atan(10.0), 
tlme(H,M,S,F), 

wrIte( M ATAN : M ,H, M :■,M,": M ,S,".",F),nI. 
cycleatan(N, R) s- 

N > 0, N1 « N - 1, R « atan(10.0), eye Ieatan(N1,R). 

cyclesin(0,R) s- R « sin(10.0), 
tlme(H,M,S,F), 

wr t te("SIN : M ,H, M : M ,M,": M ,S,". M ,F),nI. 

cyclesin(N, R) 

N > 0. N1 - N - 1, R - sln(10.0) # eye Iesin(N1,R). 


Listing 5. Turbo Prolog Factorial Test Program. 
/* Turbo Prolog Factorial Benchmark Test */ 
predicates 

factorial(reaI,reaI ) 
repeat(Integer,real) 

goa I 

cIearwindow, 

wrlte("Enter number of iterations ")* 

readlnt(Iter),nl, 

write("Enter factorial number "), 

readreaI(NumJ.nl,nI, 

tlme(0,0,0,0;, 

repeat(Iter,Num), 

time(H,M,$,F),nI, 

wr I te("Tlme - " ,H. ": " ,M. ": •' ,S, ". M ,F) ,n I. 
clauses 

factor I a I(1.1) 1. 

factor I a I(N.Resu11) 

N1 - N - 1, 

factorial(N1, Temporary), 

Result - N * Temporary. 

repeat(0,R) factor la I(R,X), 
wrlte(X),nI. 

repeat(N.R) 

factorial(R,_) t 
N1 - N - 1, 
repeat(N1,R). 


(continued) 


BYTE LISTINGS SUPPLEMENT • JULY-SEPTEMBER. 1986 297 








September 


Listing 6. Turbo Prolog Towsr of Hanoi Test Program. 
/* Turbo Prolog Towsr of Hanoi Test Program */ 
domains 

list ■ Integer* 

predicates 
hand (Integer) 

move(integer.symbol.symbol.symbol) 
move2(symboI,symboI,symboI) 

goa I 

wr Ite( M Enter tower height M ), 
readint(Hlgh), 
time(0,0,0,0), 
hanol(High). 
time(H.M.S.F), 

wrIte("Tlme : . 

CIOU S 68 

hanol(N) move(N. left, center, right). 
move(0, _):-!. 

move(N, A. B, C) 

M - N - 1. 
move(M, A. C, B). 
move2(bottom, A. B), 
move(M, C. B. A). 
move2(bottom, A, B) 

wr lte("Move the disk on "), 

wr Ite(A), 

write(" to M ), 

wrlte(B), 

nl. 


Listing 7. Turbo Prolog Disk Write Test Program. 
/* Turbo Prolog Disk write benchmark */ 
domains 

file- textfile 

predicates 

send_text(integer) 

goal 

openwr11 e(text f1 1 e. M a:tempo.dat"), 

wrItedevice(textfIle), 

t!me(0,0.0.0), 

send_text(512), 

tlme(H.M.S.F), 

closeFiIe(textflie), 

writedevIce(screen), 

wr i te("Time « ” ,H, ": ” ,M, ": M ,S ,".\F), nl. 
write("DONE"),n 1. 


cIauses 




Listing 8. Turbo Prolog Disk Read Program. 
/* Turbo Prolog Disk Write Program */ 
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domains 

file- textfIle 

predicates 

get_text(Integer) 

goal 

openread(textfIle,"a:tempo.dat"). 
readdevlce(textfIle), 

11 me(0,0,0,0), 
get_text(512), 
tlme(H,M,S,F), 
closeFIIe(textf1I e), 

wr I te("TIme - ”,H, ":'\M, M : M ,S, M ,F), nl, 
wrIte("DONE"),nI. 


clauses 

get_text(0). 
get_text(N) :- 
Readln(Str), 
not (lsname(Str)), 
Nl = N - 1, 
get_text(Nl). 


xmodem.asm 

Programming Project:"CaIcuI ating CRCs by Bits and Bytes,” 
by Greg Morse. September, page 114. Also see xmodem.c, 
sdlc.asm, and ccltt.c. 


* .... omitted lines same as for SDLC version 

♦ 


♦ Note 

changed order of these next 

four statements 

♦ 

Temp 

rmb 

1 ; ;keep 


CRCReg 

equ 

. ;; these 


CRCHI 

rmb 

1 ;; statements 

CRCLo 

rmb 

i ;; 

together 

stakbot 

rmb 

200-. 


CRCMem 

equ 

• 


* 

*.... omitted 

calling code same as 

for SDLC version 


* part B: Calculation subroutine 

* XCRC - 28 AUG 85 

* PUBLIC DOMAIN SOFTWARE DONATED BY: 

* GREG MORSE Richmond B.C. CANADA 

* 

CRCRtn equ * begin BYTE-wise XMODEM-CRC 
*; + 

* Calculate the XMODEM-CRC value for a block of data 

* Polynomial used - X**16 + X**12 +X**5 +1 

* on entry: 

* X points to data buffer 

* D contains number of chars In buffer <- 32767 

* mem locations Temp, CRCHI, CRCLo are don’t care 

* They must be adjacent locations with Temp at the 

* low address. 

* On Exit 

* X point past last char In buffer 

* D new CRC value for block 

* CRCHI,CRCLO new CRC for block 

* Temp destroyed 

* 

* DOC NOTES: 

* T - Data eor CRCHI 

* U « (T7 T6 T5 T4 0 0 0 0) eor (T3 T2 T1 T0 0 0 0 0) 

* During calcs CrcHI not needed so is used as 

* scratch area. 

* The Inner loop from CRC.10 takes 90 cycles 


(continued) 
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* The routine 

* 2 bytes for 


pshs 
leay 
pshs 
I dd 
std 
oByt equ 
* 


y 

d,x 

y 

#0 

CRCReg 
* 


requires 1 byte of scratch 
the result, and 6 bytes of stack 

save users y 

•tart addr + byte count equals 
ending address plus 1 

In It CRC to all 0’s 
InitialIze CRC area 
at entry point for 1 byte CRC calc 

T Ad rArum 


Ida 

CRCHI 

CRC.10 equ 

eora 

*X 4 

tfr 

o,b 

andb 

#$F0 

anda 

#$0F 

std 

Isrb 

Isrb 

Isrb 

1 srb 

Temp 

eorb 

Temp 

eorb 

CRCHI 

stb 
cl ra 

1 s 1 b 
ro 1 a 
Is lb 
rola 
Is lb 
rola 
Islb 
ro 1 a 

Temp 

stb 

Islb 

rola 

CRCHI 

eora 

CRCHI 

eora 

CRCLo 

eorb 

std 

CRC.99 

equ 



B a 2{5 T6 n T5 T4°T3°T2 T1 # ~ P? - byt# ° YCLE5 
A-T7 T6 T5 T4 T3 T2 T1 

B-T7 T6 T5 T4 0 0 0 

A- 0 0 0 0 T3 T2 T1 

8av« A->temp; B->CRCHI 
B- 0 T7 T6 T5 T4 0 0 0 

B- 0 0 T7 T6 T5 T4 0 0 

B- 0 0 0 T7 T6 T5 T4 0 

B- 0 0 0 0 T7 T6 T5 T4 

B- 0 0 0 0 U7 U6 U5 U4 

B“ T7 T6 T5 T4 U7 U6 U5 U4 

temp- T7 T6 T5 T4 U7 U6 

A- 0 0 0 0 0 

A- 0 0 0 0 0 

A- 0 0 0 0 0 

B- U7 U6 U5 U4 0 „ „ „ 

A- 0 0 0 0 T7 T6 T5 T4 

B= U6 U5 U4 0 0 0 0 0 

A- 0 0 0 T7 T6 T5 T4 U7 



Temp 

CRCReg 

* 


cmpx 
bio 

A still 
leas 2,s 


CRC.10 
CRCHI 


A» new CRCHI 

B« new CRCLo K , OJ 

one data byte all done (83) 
make RTS If doing only 1 byte 
x past end of buffer? (87) 
If not repeat Inner loop Note: 


* 

FoxMsg 


puls y,pc 


pop topaddr 
restore y and return 


FoxSIz 


equ 
fee 

equ . . . 

USE shoregs.src 
emod 

CRCSIz equ * 


/THE.QUICK, BROWN.FOX .0123456789/ 
♦-FoxMsg ' 


os9 CRC bytes 


Programming Project:"CaIcuI at Ing CRCs 
by Greg Morse. September, page 114. Al 
sale.asm, and Xmodem.asm. 


by Bits and Bytes, 
so see ccltt.c, 




!r P I a J b ! t " 0rientad CRC routine */ 

/* Adopted from YMODEM protocol reference 

/* Co leu I ate CRC on o block of data */ 

/* Ptr points to block of characters.*/ 
count gives size of buffer. */ 

'* If ♦k Pr 22£°? r ? turns th * CRC with the LSB*/ 
of the CRC in the high bit of the*/ ' 

result Integer.*/ ' 

thIt 0 ?f M H d * V,at ! S fr0m CCITT standard in*/ 

that It does not use */ ' 

* inif! S n° f Ju® data f,r8t » nor does It*/ 
initialize the CRC to all */ ' 


*/ 
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/• ones as specified by the standard. */ 

int calcrc(ptr, count) 
char *ptr; 

Int count; 

unsigned Int crc; 

Int !; 

crc - 0; /* note not OxFFFF */ 

while (—count >* 0) { , t . # 

I » (Int) *ptr++; /* convert data char to int */ 

I = | « 8; /* shift char to high byte */ 

crc - crc * I; /* add current data to current */ 

/* remainder modifies only least */ 

/* sIg 8 bits (high byte) of CRC */ 
for (1*0; I<8; ++I) /* loop for each bit */ 
if (crc k 0x8000) | /* test D XOR R0 */ 
crc - (crc « 1); /* discard LSB of CRC and */ 

/* append zero */ 

crc * crc * 0x1021; /* XOR with low 16 bits */ 

/* of CCITT polynomial */ 

/* because CRC is stored LSB 1st */ 
/* polynomial written MSB first •/ 

{ /* end if */ 

else ^ . 

crc - crc « 1; /* discard LSB & append 0 •/ 

j /♦ end while */ 
return (crc k 0xFFFF);*/ 

/* 16-bit result for whole block */ 

| /* end calcrc */ 
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DISKS AND DOWNLOADS 


Ordering Disks of byte Listings 

Listings that accompany BYTE articles are sva: abie 
in a variety of disk formats and on Cauz - f: ~r.ro. 
Each disk package (which sometimes corrs ss of 
more than one disk) contains an e~: -e s 
listings. If you want to order a disk cir-age from a 
previous month, please call (6031 :: : rd 

out how many disks it includes To order 
(for noncommercial use only), fill cu: r s form, and 
send a check or money order in the c:~er: 
amount to: 

BYTE Listings 

One Phoenix Mill Lane 

Peterborough. NH 03458 

All prices include postage Program Ssdags can 
also be downloaded via BYTEnet . at (617) 
861-9764. 

BYTE issue: __ 

COMMON 514-INCH FORMATS 

All cost $8.95. $10.95 outsics -rrsal 

subscription is $69.95. $89 : _*a oe . 5 1 

□ Apple II 514-inch DOS 3.3 

□ Apple II 514-inch ProDOS 

□ Hewlett-Packard 125 

□ IBM PC 

□ Kaypro 2 CP/M 

□ Texas Instruments Profess :*a 

□ TRS-80 Model III 

□ TRS-80 Model 4 

□ Zenith Z-100 

COMMON 3'/HNCH FORMATS 
All cost $9.95. $11.95 outside . 
subscription is $79.95 $=v ce .5 A 

□ Apple Macintosh 

□ Atari 520ST 

□ Commodore Amiga 

□ Data General/One 

□ Hewlett-Packard 150 

CP/M STANDARD ft-MCH FORMAT 

All cost $9 95. $11.95 oxsa de USA Annual 

subscription is S79.95. 999.95 outside USA 

□ Single-s:ded src-e-oe^sr. 

□ Double-scoec aouDe-dersty 


OTHER FORMATS 

Due to the diversity of requests and the custom 
work involved, there will be some delay in fu-£ 
these requests. All cost $9.95. $11.95 outside USA 
Annual subscription is $79.95. $99.95 outside 
US. A. 

Size □ 8-inch □ 514-inch □314-inch 
Machine_ 

SEND TO: 

Name_ 

Street__ 

City_State or Province_ 

Postal Code_Country_ 

Check or money order enclosed for $_ 

Bulletin Boards in Canada 

Listed below are some computer bulletin boards 
that carry program listings from BYTE. Programs 
are for noncommercial use in connection with 
BYTE articles only. Some BBSs may charge an 
annual maintenance fee. and you must pay your 
own telephone charges. 

Western Canadian Distribution Center (3420 48th 
St.. Edmonton. Alberta T6L 3R5i will be supplying 
listings to its member bulletin board systems. 
Edmonton. Alberta. (403) 454-6093 
Meadowlark. Alberta. (403) 435-6579 
Montreal. Quebec. PComm Systems. (514) 989-9450 
Prince George. British Columbia. (604) 562-9519 
Regina. Saskatchewan. (306) 586-5585 
Canadian Remote Systems. Toronto 

Toronto. Ontario. Epson Club of Toronto (EPCOT). 
(416) 635-9600 

Winnipeg. Manitoba. (204) 452-5529 

In addition, arrangements for BYTEnet Listings have 
been made with one or more system operators in 
the following nations: Australia Austria, Brazil, Den¬ 
mark. France. Hong Kong. Indonesia Italy, lapan. 
Malaysia. The Netherlands. Niger-.a Norway. Saudi 
Arabia. Singapore. Sweden. Switzerland. United 
Kingdom, and West Germany Contact us at (603) 
924-9281 for an up-to-date list ■ 
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EDITORIAL CALENDAR 


1987 


MAY — DESKTOP PUBLISHING: An exploration of the hardware and software needed for desktop publishing, 
from page description languages to high-resolution printers and typesetting back ends. 

June — Computer-Aided Design: The anatomy of computer-aided design/drafting software, the graphics 
display devices needed for CAD. and the data structures used by CAD programs to export data to other 
applications. 

July — Local Area Networks: The technology of linking personal computers together to share data 
files, programs, and peripheral devices. 

AUGUST — PROLOG: A look at logic programming with articles on tips and techniques and explorations of 
the tasks Prolog is best suited for. 

SEPTEMBER — PRINTER TECHNOLOGIES: An examination of the state of the art in printer technologies, 
including laser, liquid-crystal shutter, and ink-jet technologies. 

OCTOBER — HEURISTIC ALGORITHMS: Artificial intelligence techniques for giving computers the ability 


to learn from experience. 


November — High-Performance Workstations: a tour of the technology underlying the work¬ 
stations used by scientists and engineers in computer-aided engineering/design. 

December — Natural Language Processing: The technology of getting computers to under¬ 
stand the natural language of man. 



January — Managing Megabytes: Looking at the ways computers store and retrieve data in situations 
where disk space is measured in gigabytes and memory is measured in megabytes. Also a look at the 
new applications that mega-memory and storage will permit. 

FEBRUARY — LISP: A BYTE reexamination of the original language of artificial intelligence research. 

March — Floating-Point Processors: a look at the processors that speed the computation of 
mathematical operations in personal computers, including coprocessors and array processors. 

April — Memory Management The hardware and software issues in managing a personal computer's 
memory space. 

MAY — CPU ARCHITECTURES: An exploration of the latest 32-bit microprocessors, including digital signal 
processors and programmable graphics processors. 
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Six great reasons 


• Over 140 microcomputer related c onf er e n c es: 

loin only those subjects that in a eica 90a and change 
selections at any time Take part when it's M| 
for you. Share information, opi n io ns and ideas in 
focused discussions with other BOC u ser s who s ha re 
your interests. Easy commands and co nfere nce cfigests 
help you quickly locate important Monnafion. 

• Monthly conference specials: 

BIX specials connect you with invited experts in lead- 
ing-edge topics—CD-ROM MID! OS - arc ~ :~t 
They're all part of your BIX members* : 

• Microbytes daily: 

Get up-to-the-minute industry news arc re* r-: c.r 
information by joining Microbytes Da: ., arc 5 
New Hardware and Software. 

• Public domain software: 

Yours for the downloading, including programs ; *:~ 
BYTE articles and a growing library of PD listings 

• Electronic mail: 

Exchange private messages with BYTE ecr.zs a~r 
authors and other BIX users. 


to join BIX today 



BIX User's Manual and Subscriber Agreement 
- otm as We've Processed Your Registration. 
JOIN THE EXCITING WORLD 
OF BIX TODAY! 


• Vendor support: 

A growing number of microcompute' manufacturers 
use BIX to answer your questions about re - products 
and how to use them for peak perforrarce 


What BIX Costs. .How You Pay 


Join BIX Right Now: 

Set your computer's telecommunications program for 
full duplex. 8-bit characters, even parity. 1 stop bit OR 
7-bit characters, even parity. 1 stop using 300 or 1200 
baud. 

Call your local Tymnet number and respond as follows 


ONE-TIME REGISTRATION FEE S25 


Hourly 

Charges: 

(Your Time 
of Access) 


Off-Peak 

6PM-7AM 

Weekdays Plus 
Weekends 
& Holidays 


Peak 

7AM-6PM 

Weekdays 


Tymnet Prompt 


You Enter 


Garble or "terminal identifier" 

login: 

password: 

mhis login: 

BIX Logo—Name: 


a 

byteneti <CR> 
mgh <CR> 
bix <CR> 
new <CR> 


BIX $9 $12 

Tymnet* $2 $6 

TOTAL $ ll/hr. SI 8/hr.** 

* Continental US. BIX is accessible via Tymnet from throughout the US. at charges 
much less than regular long distance. Call the BIX helpline number listed below 
for the Tymnet number near you or Tymnet at 1-800-336-0149 
•* User is billed for time on system lie.. Vt Hr Off-Peak wfTymnet - $5.50 charge.) 

BIX and Tymnet charges billed by Visa or Mastercard only. 

BIX Helpline 

(8:30 AM-11:30 PM Eastern Weekdays) 

U.S. (except NH)-1-800-227-BYTE 
Elsewhere (603) 924-7681 


After you register on-line, you're immediately taken to 
the BIX learn conference and can start using the system 
right away. 

Foreign Access: 

To access BIX from foreign countries, you must have 
an account with your local Postal Telephone & Telegraph 
(PTT) company. From your PTT enter 310600157878. 
Then enter bix <CR > and new <CR > at the prompts. 
Call or write us for PTT contact information. 

EIX 

One Phoenix Mill Lane 
Peterborough. NH 03458 
(603) 924-9281 





Announcing BYTE’s 
New Subscriber Benefits 


Y 

^OU 


Program 


our BYTE subscription brings 
you a complete diet of the latest in 
microcomputer technology every 
30 days. The kind of broad-based 
objective coverage you read in 
every issue. In addition, your 
subscription carries a wealth of 
other benefits. Check the check 
list: 

DISCOUNTS 

13 issues instead of 12 if you 
send payment with subscription 
order. 

yf One-year subscription at $21 
(50% off cover price). 

vf Two-year subscription at $38. 

Vf Three-year subscription at $55. 

Ef One-year GROUP subscription 
for ten or more at $17.50 each. 
(Call or write for details.) 

SERVICES 

33 BIX: BYTE’s Information 
Exchange puts you on-line 24 
hours a day with your peers 
via computer conferencing and 
electronic mail. All you need to 
sign up is a microcomputer, a 
modem, and telecomm 
software. 

Reader Service: For information 
on products advertised in 
BYTE, circle the numbers on 
the Reader Service card 
enclosed in each issue that 
correspond to the numbers for 
the advertisers you select. Drop 
it in the mail and we’ll get 
your inquiries to the advertisers. 

ii TIPS: BYTE’s Telephone 
Inquiry System is available to 


BITE 
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subscribers who need fast 
response. After obtaining your 
Subscriber I.D. Card, dial TIPS 
and enter your inquiries. You’ll 
save as much as ten days over 
the response to Reader Service 
cards. 

V Disks and Downloads: 

Listings of programs that 
accompany BYTE articles are 
now available free on the 
BYTEnet bulletin board, and 
on disk or in quarterly printed 
supplements. 

Sj Microform: BYTE is available 
in microform from University 
Microfilm International in the 
U.S. and Europe. 

2 BYTE’s BOMB: BYTE’s 
Ongoing Monitor Box is your 
direct line to the editor’s desk. 
Each month, you can rate the 
articles via the Reader Service 
card. Your feedback helps us 


keep up to date on your 
information needs. 

if Customer Service: If you have 
a problem with, or a question 
about, your subscription, you 
may phone us during regular 
business hours (Eastern time) 
at our toll-free number: 800- 
258-5485. You can also use 
Customer Service to obtain 
back issues and editorial indexes. 

BONUSES 

}/ Annual Separate Issues: In 
addition to BYTE’s 12 monthly 
issues, subscribers also receive 
our annual IBM PC issue free 
of charge, as well as any other 
annual issues BYTE may 
produce. 

0 BYTE Deck: Subscribers 
receive five BYTE postcard 
deck mailings each year—a 
direct response system for you 
to obtain information on 
advertised products through 
return mail. 

To be on the leading edge of 
microcomputer technology and 
receive all the aforementioned 
benefits, make a career decision 
today. Call toll-free weekdays, 
8:30am to 4:30pm Eastern time: 
800-258-5485. 

And. . . welcome to 
BYTE country! 
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